From: simonmar Date: Fri, 18 Mar 2005 13:41:59 +0000 (+0000) Subject: [project @ 2005-03-18 13:37:27 by simonmar] X-Git-Tag: Initial_conversion_from_CVS_complete~885 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;ds=sidebyside;h=d1c1b7d0e7b94ede238845c91f58582bad3b3ef3;p=ghc-hetmet.git [project @ 2005-03-18 13:37:27 by simonmar] Flags cleanup. Basically the purpose of this commit is to move more of the compiler's global state into DynFlags, which is moving in the direction we need to go for the GHC API which can have multiple active sessions supported by a single GHC instance. Before: $ grep 'global_var' */*hs | wc -l 78 After: $ grep 'global_var' */*hs | wc -l 27 Well, it's an improvement. Most of what's left won't really affect our ability to host multiple sessions. Lots of static flags have become dynamic flags (yay!). Notably lots of flags that we used to think of as "driver" flags, like -I and -L, are now dynamic. The most notable static flags left behind are the "way" flags, eg. -prof. It would be nice to fix this, but it isn't urgent. On the way, lots of cleanup has happened. Everything related to static and dynamic flags lives in StaticFlags and DynFlags respectively, and they share a common command-line parser library in CmdLineParser. The flags related to modes (--makde, --interactive etc.) are now private to the front end: in fact private to Main itself, for now. --- diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 63ef83f..f2c70c3 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -112,7 +112,7 @@ import Maybes ( orElse ) import SrcLoc ( SrcLoc ) import Outputable import Unique ( Unique, mkBuiltinUnique ) -import CmdLineOpts ( opt_NoStateHack ) +import StaticFlags ( opt_NoStateHack ) -- infixl so you can say (id `set` a `set` b) infixl 1 `setIdUnfolding`, diff --git a/ghc/compiler/basicTypes/NewDemand.lhs b/ghc/compiler/basicTypes/NewDemand.lhs index 4b58fd5..8e68fd8 100644 --- a/ghc/compiler/basicTypes/NewDemand.lhs +++ b/ghc/compiler/basicTypes/NewDemand.lhs @@ -24,7 +24,7 @@ module NewDemand( #include "HsVersions.h" -import CmdLineOpts ( opt_CprOff ) +import StaticFlags ( opt_CprOff ) import BasicTypes ( Arity ) import VarEnv ( VarEnv, emptyVarEnv, isEmptyVarEnv ) import UniqFM ( ufmToList ) diff --git a/ghc/compiler/basicTypes/VarEnv.lhs b/ghc/compiler/basicTypes/VarEnv.lhs index d3b9bcb..a4579b4 100644 --- a/ghc/compiler/basicTypes/VarEnv.lhs +++ b/ghc/compiler/basicTypes/VarEnv.lhs @@ -41,7 +41,7 @@ import UniqFM import Unique ( Unique, deriveUnique, getUnique ) import Util ( zipEqual, foldl2 ) import Maybes ( orElse, isJust ) -import CmdLineOpts ( opt_PprStyle_Debug ) +import StaticFlags( opt_PprStyle_Debug ) import Outputable import FastTypes \end{code} diff --git a/ghc/compiler/cmm/CLabel.hs b/ghc/compiler/cmm/CLabel.hs index feec598..f9f2ead 100644 --- a/ghc/compiler/cmm/CLabel.hs +++ b/ghc/compiler/cmm/CLabel.hs @@ -99,7 +99,8 @@ module CLabel ( #include "HsVersions.h" -import CmdLineOpts ( DynFlags, opt_Static, opt_DoTickyProfiling ) +import DynFlags ( DynFlags ) +import StaticFlags ( opt_Static, opt_DoTickyProfiling ) import Packages ( isHomeModule, isDllName ) import DataCon ( ConTag ) import Module ( moduleFS, Module ) diff --git a/ghc/compiler/cmm/CmmParse.y b/ghc/compiler/cmm/CmmParse.y index b852eb3..3ae93ff 100644 --- a/ghc/compiler/cmm/CmmParse.y +++ b/ghc/compiler/cmm/CmmParse.y @@ -37,7 +37,8 @@ import Literal ( mkMachInt ) import Unique import UniqFM import SrcLoc -import CmdLineOpts ( DynFlags, DynFlag(..), opt_SccProfilingOn ) +import DynFlags ( DynFlags, DynFlag(..) ) +import StaticFlags ( opt_SccProfilingOn ) import ErrUtils ( printError, dumpIfSet_dyn, showPass ) import StringBuffer ( hGetStringBuffer ) import FastString diff --git a/ghc/compiler/cmm/PprC.hs b/ghc/compiler/cmm/PprC.hs index 824179c..04c8194 100644 --- a/ghc/compiler/cmm/PprC.hs +++ b/ghc/compiler/cmm/PprC.hs @@ -37,7 +37,7 @@ import UniqFM ( eltsUFM ) import FastString import Outputable import Constants -import CmdLineOpts ( opt_EnsureSplittableC ) +import StaticFlags ( opt_SplitObjs ) -- The rest import Data.List ( intersperse, groupBy ) @@ -67,8 +67,8 @@ writeCs handle cmms = printForUser handle alwaysQualify (pprCs cmms) -- ToDo: should be printForC split_marker - | opt_EnsureSplittableC = ptext SLIT("__STG_SPLIT_MARKER") - | otherwise = empty + | opt_SplitObjs = ptext SLIT("__STG_SPLIT_MARKER") + | otherwise = empty -- -------------------------------------------------------------------------- -- Now do some real work diff --git a/ghc/compiler/codeGen/CgCallConv.hs b/ghc/compiler/codeGen/CgCallConv.hs index 7be8b84..9b73c3b 100644 --- a/ghc/compiler/codeGen/CgCallConv.hs +++ b/ghc/compiler/codeGen/CgCallConv.hs @@ -58,7 +58,7 @@ import TyCon ( TyCon, tyConFamilySize ) import Bitmap ( Bitmap, mAX_SMALL_BITMAP_SIZE, mkBitmap, intsToReverseBitmap ) import Util ( isn'tIn, sortLe ) -import CmdLineOpts ( opt_Unregisterised ) +import StaticFlags ( opt_Unregisterised ) import FastString ( LitString ) import Outputable import DATA_BITS diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 82bdec3..fad78d8 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgCase.lhs,v 1.72 2004/11/26 16:19:59 simonmar Exp $ +% $Id: CgCase.lhs,v 1.73 2005/03/18 13:37:38 simonmar Exp $ % %******************************************************** %* * @@ -48,7 +48,7 @@ import CmmUtils ( CmmStmts, noStmts, oneStmt, plusStmts ) import Cmm import MachOp ( wordRep ) import ClosureInfo ( mkLFArgument ) -import CmdLineOpts ( opt_SccProfilingOn ) +import StaticFlags ( opt_SccProfilingOn ) import Id ( Id, idName, isDeadBinder, idType ) import ForeignCall ( ForeignCall(..), CCallSpec(..), playSafe ) import VarSet ( varSetElems ) diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 3c8066b..3c3d4e2 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgClosure.lhs,v 1.66 2004/12/08 14:32:29 simonpj Exp $ +% $Id: CgClosure.lhs,v 1.67 2005/03/18 13:37:40 simonmar Exp $ % \section[CgClosure]{Code generation for closures} @@ -42,7 +42,7 @@ import CmmUtils ( CmmStmts, mkStmts, oneStmt, plusStmts, noStmts, mkLblExpr ) import CLabel import StgSyn -import CmdLineOpts ( opt_DoTickyProfiling ) +import StaticFlags ( opt_DoTickyProfiling ) import CostCentre import Id ( Id, idName, idType ) import Name ( Name ) diff --git a/ghc/compiler/codeGen/CgForeignCall.hs b/ghc/compiler/codeGen/CgForeignCall.hs index 1f25faf..572a387 100644 --- a/ghc/compiler/codeGen/CgForeignCall.hs +++ b/ghc/compiler/codeGen/CgForeignCall.hs @@ -32,7 +32,7 @@ import MachOp import SMRep import ForeignCall import Constants -import CmdLineOpts ( opt_SccProfilingOn ) +import StaticFlags ( opt_SccProfilingOn ) import Outputable import Monad ( when ) diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index b0bdf46..e154bed 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgHeapery.lhs,v 1.43 2005/02/10 13:01:53 simonmar Exp $ +% $Id: CgHeapery.lhs,v 1.44 2005/03/18 13:37:42 simonmar Exp $ % \section[CgHeapery]{Heap management functions} @@ -53,7 +53,7 @@ import TyCon ( tyConPrimRep ) import CostCentre ( CostCentreStack ) import Util ( mapAccumL, filterOut ) import Constants ( wORD_SIZE ) -import CmdLineOpts ( DynFlags ) +import DynFlags ( DynFlags ) import Outputable import GLAEXTS diff --git a/ghc/compiler/codeGen/CgInfoTbls.hs b/ghc/compiler/codeGen/CgInfoTbls.hs index 2183d89..940852d 100644 --- a/ghc/compiler/codeGen/CgInfoTbls.hs +++ b/ghc/compiler/codeGen/CgInfoTbls.hs @@ -57,7 +57,8 @@ import StgSyn ( SRT(..) ) import Name ( Name ) import DataCon ( DataCon, dataConTag, fIRST_TAG ) import Unique ( Uniquable(..) ) -import CmdLineOpts ( opt_SccProfilingOn, DynFlags(..), HscTarget(..) ) +import DynFlags ( DynFlags(..), HscTarget(..) ) +import StaticFlags ( opt_SccProfilingOn ) import ListSetOps ( assocDefault ) import Maybes ( isJust ) import Constants ( wORD_SIZE, sIZEOF_StgFunInfoExtraRev ) diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index 4ba8f09..4160580 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgMonad.lhs,v 1.43 2004/12/08 14:32:31 simonpj Exp $ +% $Id: CgMonad.lhs,v 1.44 2005/03/18 13:37:44 simonmar Exp $ % \section[CgMonad]{The code generation monad} @@ -61,7 +61,7 @@ module CgMonad ( import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds ) -import CmdLineOpts ( DynFlags ) +import DynFlags ( DynFlags ) import Cmm import CmmUtils ( CmmStmts, isNopStmt ) import CLabel diff --git a/ghc/compiler/codeGen/CgParallel.hs b/ghc/compiler/codeGen/CgParallel.hs index 74cbeb5..b826a33 100644 --- a/ghc/compiler/codeGen/CgParallel.hs +++ b/ghc/compiler/codeGen/CgParallel.hs @@ -12,7 +12,7 @@ import CgMonad import CgCallConv ( mkRegLiveness ) import Id ( Id ) import Cmm ( CmmLit, GlobalReg(..), node, CmmExpr ) -import CmdLineOpts ( opt_GranMacros ) +import StaticFlags ( opt_GranMacros ) import Outputable staticParHdr :: [CmmLit] diff --git a/ghc/compiler/codeGen/CgProf.hs b/ghc/compiler/codeGen/CgProf.hs index f43982d..aa654fd 100644 --- a/ghc/compiler/codeGen/CgProf.hs +++ b/ghc/compiler/codeGen/CgProf.hs @@ -47,7 +47,7 @@ import Module ( moduleUserString ) import Id ( Id ) import CostCentre import StgSyn ( GenStgExpr(..), StgExpr ) -import CmdLineOpts ( opt_SccProfilingOn ) +import StaticFlags ( opt_SccProfilingOn ) import FastString ( FastString, mkFastString, LitString ) import Constants -- Lots of field offsets import Outputable diff --git a/ghc/compiler/codeGen/CgTicky.hs b/ghc/compiler/codeGen/CgTicky.hs index 19dbc43..3e72981 100644 --- a/ghc/compiler/codeGen/CgTicky.hs +++ b/ghc/compiler/codeGen/CgTicky.hs @@ -53,7 +53,7 @@ import CLabel ( CLabel, mkRtsDataLabel, mkRednCountsLabel ) import Name ( isInternalName ) import Id ( Id, idType ) -import CmdLineOpts ( opt_DoTickyProfiling ) +import StaticFlags ( opt_DoTickyProfiling ) import BasicTypes ( Arity ) import FastString ( FastString, mkFastString, LitString ) import Constants -- Lots of field offsets diff --git a/ghc/compiler/codeGen/CgUtils.hs b/ghc/compiler/codeGen/CgUtils.hs index c8cae4b..643c491 100644 --- a/ghc/compiler/codeGen/CgUtils.hs +++ b/ghc/compiler/codeGen/CgUtils.hs @@ -52,7 +52,7 @@ import CLabel ( CLabel, mkStringLitLabel ) import Digraph ( SCC(..), stronglyConnComp ) import ListSetOps ( assocDefault ) import Util ( filterOut, sortLe ) -import CmdLineOpts ( DynFlags(..), HscTarget(..) ) +import DynFlags ( DynFlags(..), HscTarget(..) ) import FastString ( LitString, FastString, unpackFS ) import Outputable diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index dbd4314..a0b18eb 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -63,7 +63,8 @@ import CLabel import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject ) import Packages ( isDllName ) -import CmdLineOpts ( DynFlags, opt_SccProfilingOn, opt_OmitBlackHoling, +import DynFlags ( DynFlags ) +import StaticFlags ( opt_SccProfilingOn, opt_OmitBlackHoling, opt_Parallel, opt_DoTickyProfiling, opt_SMP ) import Id ( Id, idType, idArity, idName ) diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 608ff92..fa92421 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -19,8 +19,6 @@ module CodeGen ( codeGen ) where #include "HsVersions.h" -import DriverState ( v_Build_tag, v_MainModIs ) - -- Kludge (??) so that CgExpr is reached via at least one non-SOURCE -- import. Before, that wasn't the case, and CM therefore didn't -- bother to compile it. @@ -41,8 +39,8 @@ import MachOp ( wordRep, MachHint(..) ) import StgSyn import PrelNames ( gHC_PRIM, rOOT_MAIN, mAIN, pREL_TOP_HANDLER ) -import CmdLineOpts ( DynFlags, DynFlag(..), opt_EnsureSplittableC, - opt_SccProfilingOn ) +import DynFlags ( DynFlags(..), DynFlag(..) ) +import StaticFlags ( opt_SplitObjs, opt_SccProfilingOn ) import HscTypes ( ForeignStubs(..), TypeEnv, typeEnvTyCons ) import CostCentre ( CollectedCCs ) @@ -75,8 +73,8 @@ codeGen dflags this_mod type_env foreign_stubs imported_mods cost_centre_info stg_binds = do { showPass dflags "CodeGen" - ; way <- readIORef v_Build_tag - ; mb_main_mod <- readIORef v_MainModIs + ; let way = buildTag dflags + mb_main_mod = mainModIs dflags ; let tycons = typeEnvTyCons type_env data_tycons = filter isDataTyCon tycons @@ -346,7 +344,7 @@ which refers to this name). \begin{code} maybeExternaliseId :: Id -> FCode Id maybeExternaliseId id - | opt_EnsureSplittableC, -- Externalise the name for -split-objs + | opt_SplitObjs, -- Externalise the name for -split-objs isInternalName name = do { mod <- moduleName ; returnFC (setIdName id (externalise mod)) } | otherwise = returnFC id diff --git a/ghc/compiler/codeGen/SMRep.lhs b/ghc/compiler/codeGen/SMRep.lhs index 8bbf79d..1ffbcda 100644 --- a/ghc/compiler/codeGen/SMRep.lhs +++ b/ghc/compiler/codeGen/SMRep.lhs @@ -42,7 +42,8 @@ import Id ( Id, idType ) import Type ( Type, typePrimRep, PrimRep(..) ) import TyCon ( TyCon, tyConPrimRep ) import MachOp-- ( MachRep(..), MachHint(..), wordRep ) -import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros, opt_Unregisterised ) +import StaticFlags ( opt_SccProfilingOn, opt_GranMacros, + opt_Unregisterised ) import Constants import Outputable diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 7467e47..79735bcb 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -10,7 +10,7 @@ module CompManager ( CmState, -- Abstract - cmInit, -- :: GhciMode -> IO CmState + cmInit, -- :: GhcMode -> IO CmState cmDepAnal, -- :: CmState -> [FilePath] -> IO ModuleGraph cmDownsweep, @@ -58,19 +58,18 @@ where import Packages ( isHomePackage ) import DriverPipeline ( CompResult(..), preprocess, compile, link ) import HscMain ( newHscEnv ) -import DriverState ( v_Output_file, v_NoHsMain, v_MainModIs ) import DriverPhases ( HscSource(..), hscSourceString, isHaskellSrcFilename ) import Finder ( findModule, findLinkable, addHomeModuleToFinder, flushFinderCache, mkHomeModLocation, FindResult(..), cantFindError ) -import HscTypes ( ModSummary(..), HomeModInfo(..), ModIface(..), msHsFilePath, - HscEnv(..), GhciMode(..), isBootSummary, +import HscTypes ( ModSummary(..), HomeModInfo(..), ModIface(..), + msHsFilePath, HscEnv(..), isBootSummary, InteractiveContext(..), emptyInteractiveContext, - HomePackageTable, emptyHomePackageTable, IsBootInterface, - Linkable(..), isObjectLinkable ) -import Module ( Module, mkModule, delModuleEnv, delModuleEnvList, mkModuleEnv, - lookupModuleEnv, moduleEnvElts, extendModuleEnv, filterModuleEnv, - moduleUserString, addBootSuffixLocn, - ModLocation(..) ) + HomePackageTable, emptyHomePackageTable, + IsBootInterface, Linkable(..), isObjectLinkable ) +import Module ( Module, mkModule, delModuleEnv, delModuleEnvList, + mkModuleEnv, lookupModuleEnv, moduleEnvElts, + extendModuleEnv, filterModuleEnv, moduleUserString, + addBootSuffixLocn, ModLocation(..) ) import GetImports ( getImports ) import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs ) import ErrUtils ( showPass ) @@ -80,12 +79,10 @@ import StringBuffer ( hGetStringBuffer ) import Util import Outputable import Panic -import CmdLineOpts ( DynFlags(..) ) +import DynFlags ( DynFlags(..), DynFlag(..), GhcMode(..), dopt ) import Maybes ( expectJust, orElse, mapCatMaybes ) import FiniteMap -import DATA_IOREF ( readIORef ) - #ifdef GHCI import Finder ( findPackageModule ) import HscMain ( hscGetInfo, GetInfoResult, hscStmt, hscTcExpr, hscKcType ) @@ -102,7 +99,7 @@ import Linker ( HValue, unload, extendLinkEnv ) import GHC.Exts ( unsafeCoerce# ) import Foreign import Control.Exception as Exception ( Exception, try ) -import CmdLineOpts ( DynFlag(..), dopt_unset, dopt ) +import DynFlags ( DynFlag(..), dopt_unset, dopt ) #endif import EXCEPTION ( throwDyn ) @@ -183,9 +180,9 @@ cmGetPrintUnqual cmstate = icPrintUnqual (cm_ic cmstate) cmHPT cmstate = hsc_HPT (cm_hsc cmstate) #endif -cmInit :: GhciMode -> DynFlags -> IO CmState -cmInit ghci_mode dflags - = do { hsc_env <- newHscEnv ghci_mode dflags +cmInit :: DynFlags -> IO CmState +cmInit dflags + = do { hsc_env <- newHscEnv dflags ; return (CmState { cm_hsc = hsc_env, cm_mg = emptyMG, cm_ic = emptyInteractiveContext })} @@ -499,8 +496,8 @@ cmUnload state@CmState{ cm_hsc = hsc_env } return (discardCMInfo state) cm_unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' - = case hsc_mode hsc_env of - Batch -> return () + = case ghcMode (hsc_dflags hsc_env) of + BatchCompile -> return () #ifdef GHCI Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables #else @@ -523,7 +520,7 @@ cm_unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkable cmDepAnal :: CmState -> [FilePath] -> IO ModuleGraph cmDepAnal cmstate rootnames = do showPass dflags "Chasing dependencies" - when (verbosity dflags >= 1 && gmode == Batch) $ + when (verbosity dflags >= 1 && gmode == BatchCompile) $ hPutStrLn stderr (showSDoc (hcat [ text "Chasing modules from: ", hcat (punctuate comma (map text rootnames))])) @@ -531,7 +528,7 @@ cmDepAnal cmstate rootnames where hsc_env = cm_hsc cmstate dflags = hsc_dflags hsc_env - gmode = hsc_mode hsc_env + gmode = ghcMode (hsc_dflags hsc_env) ----------------------------------------------------------------------------- -- The real business of the compilation manager: given a system state and @@ -548,7 +545,7 @@ cmLoadModules cmstate1 mg2unsorted = do -- version 1's are the original, before downsweep let hsc_env = cm_hsc cmstate1 let hpt1 = hsc_HPT hsc_env - let ghci_mode = hsc_mode hsc_env -- this never changes + let ghci_mode = ghcMode (hsc_dflags hsc_env) -- this never changes let dflags = hsc_dflags hsc_env -- this never changes let verb = verbosity dflags @@ -676,16 +673,15 @@ cmLoadModules cmstate1 mg2unsorted -- Clean up after ourselves cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) - -- Issue a warning for the confusing case where the user -- said '-o foo' but we're not going to do any linking. -- We attempt linking if either (a) one of the modules is -- called Main, or (b) the user said -no-hs-main, indicating -- that main() is going to come from somewhere else. -- - ofile <- readIORef v_Output_file - no_hs_main <- readIORef v_NoHsMain - mb_main_mod <- readIORef v_MainModIs + let ofile = outputFile dflags + let no_hs_main = dopt Opt_NoHsMain dflags + let mb_main_mod = mainModIs dflags let main_mod = mb_main_mod `orElse` "Main" a_root_is_Main @@ -693,7 +689,7 @@ cmLoadModules cmstate1 mg2unsorted mg2unsorted do_linking = a_root_is_Main || no_hs_main - when (ghci_mode == Batch && isJust ofile && not do_linking + when (ghci_mode == BatchCompile && isJust ofile && not do_linking && verb > 0) $ hPutStrLn stderr ("Warning: output was redirected with -o, " ++ "but no output will be generated\n" ++ @@ -778,7 +774,7 @@ ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ] -- ToDo: this pass could be merged with the preUpsweep. getValidLinkables - :: GhciMode + :: GhcMode -> [Linkable] -- old linkables -> [Module] -- all home modules -> [SCC ModSummary] -- all modules in the program, dependency order @@ -801,7 +797,7 @@ getValidLinkables mode old_linkables all_home_mods module_graph getValidLinkablesSCC - :: GhciMode + :: GhcMode -> [Linkable] -- old linkables -> [Module] -- all home modules -> [(Linkable,Bool)] @@ -823,7 +819,7 @@ getValidLinkablesSCC mode old_linkables all_home_mods new_linkables scc0 Nothing -> False Just l -> isObjectLinkable l - objects_allowed = mode == Batch || all has_object scc_allhomeimps + objects_allowed = mode == BatchCompile || all has_object scc_allhomeimps in do new_linkables' @@ -1256,7 +1252,7 @@ summariseFile dflags file (srcimps,the_imps,mod) <- getImports dflags' buf hspp_fn -- Make a ModLocation for this file - location <- mkHomeModLocation mod file + location <- mkHomeModLocation dflags mod file -- Tell the Finder cache where it is, so that subsequent calls -- to findModule will find it, even if it's not on any search path diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 60ddc5c..fbf4927 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -38,7 +38,8 @@ import Type ( Type, tyVarsOfType, coreEqType, getTvSubstEnv, getTvInScope ) import TyCon ( isPrimTyCon ) import BasicTypes ( RecFlag(..), Boxity(..), isNonRec ) -import CmdLineOpts +import StaticFlags ( opt_PprStyle_Debug ) +import DynFlags ( DynFlags, DynFlag(..), dopt ) import Outputable #ifdef DEBUG diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index d7d2a99..f918d72 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -35,7 +35,7 @@ import UniqSupply import Maybes import OrdList import ErrUtils -import CmdLineOpts +import DynFlags import Util ( listLengthCmp ) import Outputable \end{code} diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 0a2bd0d..eb790d1 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -49,7 +49,7 @@ module CoreSyn ( #include "HsVersions.h" -import CmdLineOpts ( opt_RuntimeTypes ) +import StaticFlags ( opt_RuntimeTypes ) import CostCentre ( CostCentre, noCostCentre ) import Var ( Var, Id, TyVar, isTyVar, isId ) import Type ( Type, mkTyVarTy, seqType ) diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 3327e8b..0cb1918 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -30,13 +30,11 @@ module CoreUnfold ( #include "HsVersions.h" -import CmdLineOpts ( opt_UF_CreationThreshold, - opt_UF_UseThreshold, - opt_UF_FunAppDiscount, - opt_UF_KeenessFactor, +import StaticFlags ( opt_UF_CreationThreshold, opt_UF_UseThreshold, + opt_UF_FunAppDiscount, opt_UF_KeenessFactor, opt_UF_DearOp, - DynFlags, DynFlag(..), dopt ) +import DynFlags ( DynFlags, DynFlag(..), dopt ) import CoreSyn import PprCore ( pprCoreExpr ) import OccurAnal ( occurAnalyseGlobalExpr ) diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index b07d917..f738319 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -47,7 +47,7 @@ import VarSet ( unionVarSet ) import VarEnv import Name ( hashName ) import Packages ( isDllName ) -import CmdLineOpts ( DynFlags ) +import DynFlags ( DynFlags ) import Literal ( hashLiteral, literalType, litIsDupable, litIsTrivial, isZeroLit, Literal( MachLabel ) ) import DataCon ( DataCon, dataConRepArity, dataConArgTys, diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs index d148b2b..e101a78 100644 --- a/ghc/compiler/coreSyn/MkExternalCore.lhs +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -32,7 +32,8 @@ import Literal import Name import Outputable import ForeignCall -import CmdLineOpts +import DynFlags ( DynFlags(..) ) +import StaticFlags ( opt_EmitExternalCore ) import Maybes ( mapCatMaybes ) import IO import FastString diff --git a/ghc/compiler/cprAnalysis/CprAnalyse.lhs b/ghc/compiler/cprAnalysis/CprAnalyse.lhs index a41e62f..8ca265f 100644 --- a/ghc/compiler/cprAnalysis/CprAnalyse.lhs +++ b/ghc/compiler/cprAnalysis/CprAnalyse.lhs @@ -11,7 +11,7 @@ module CprAnalyse ( cprAnalyse ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..) ) +import DynFlags ( DynFlags, DynFlag(..) ) import CoreLint ( showPass, endPass ) import CoreSyn import CoreUtils ( exprIsValue ) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index be26463..c8a5151 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -8,9 +8,10 @@ module Desugar ( deSugar, deSugarExpr ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlag(..), DynFlags(..), dopt, opt_SccProfilingOn ) +import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) ) +import StaticFlags ( opt_SccProfilingOn ) import DriverPhases ( isHsBoot ) -import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), GhciMode(..), +import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), Dependencies(..), TypeEnv, IsBootInterface ) import HsSyn ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr, HsBindGroup(..), LRuleDecl, HsBind(..) ) @@ -167,7 +168,7 @@ deSugar hsc_env where dflags = hsc_dflags hsc_env - ghci_mode = hsc_mode hsc_env + ghci_mode = ghcMode (hsc_dflags hsc_env) auto_scc | opt_SccProfilingOn = TopLevel | otherwise = NoSccs diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 369660a..70e5d16 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -24,7 +24,8 @@ import HsSyn -- lots of things import CoreSyn -- lots of things import CoreUtils ( exprType, mkInlineMe, mkSCC ) -import CmdLineOpts ( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs ) +import StaticFlags ( opt_AutoSccsOnAllToplevs, + opt_AutoSccsOnExportedToplevs ) import CostCentre ( mkAutoCC, IsCafCC(..) ) import Id ( idType, idName, isExportedId, isSpecPragmaId, Id ) import NameSet diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 1f20f59..6192d5a 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -18,7 +18,8 @@ import CoreSyn import DsMonad -- the monadery used in the desugarer import DsUtils -import CmdLineOpts ( DynFlag(..), dopt, opt_RulesOff ) +import DynFlags ( DynFlag(..), dopt ) +import StaticFlags ( opt_RulesOff ) import CoreUtils ( exprType, mkIfThenElse ) import Id ( idType ) import Var ( Id ) diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index b82a30a..552526b 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -52,7 +52,7 @@ import UniqSupply ( UniqSupply, uniqsFromSupply ) import Name ( Name, nameOccName ) import NameEnv import OccName ( occNameFS ) -import CmdLineOpts ( DynFlags ) +import DynFlags ( DynFlags ) import ErrUtils ( WarnMsg, mkWarnMsg ) import Bag ( mapBag ) diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 43471d8..3d95b71 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -8,7 +8,7 @@ module Match ( match, matchWrapper, matchSimply, matchSinglePat ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlag(..), dopt ) +import DynFlags ( DynFlag(..), dopt ) import HsSyn import TcHsSyn ( hsPatType ) import Check ( check, ExhaustivePat ) diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 5f9fe00..99e9e11 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -41,7 +41,7 @@ import VarSet ( VarSet, varSetElems ) import TysPrim ( arrayPrimTyCon, mutableArrayPrimTyCon, byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) -import CmdLineOpts ( DynFlags, DynFlag(..) ) +import DynFlags ( DynFlags, DynFlag(..) ) import ErrUtils ( showPass, dumpIfSet_dyn ) import Unique ( mkPseudoUniqueE ) import FastString ( FastString(..), unpackFS ) diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 143fb6a..b812354 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.193 2005/03/08 09:47:43 simonpj Exp $ +-- $Id: InteractiveUI.hs,v 1.194 2005/03/18 13:38:31 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -21,22 +21,20 @@ import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart, pprIfaceType ) import FunDeps ( pprFundeps ) -import DriverFlags -import DriverState -import DriverUtil ( remove_spaces ) +import Util ( removeSpaces ) import Linker ( showLinkerState, linkPackages ) import Util import Name ( Name, NamedThing(..) ) import OccName ( OccName, parenSymOcc, occNameUserString ) import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..) ) import Outputable -import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt ) +import DynFlags ( DynFlags(..), DynFlag(..), dopt ) import Panic hiding ( showException ) import Config import SrcLoc ( SrcLoc, isGoodSrcLoc ) #ifndef mingw32_HOST_OS -import DriverUtil( handle ) +import Util ( handle ) import System.Posix #if __GLASGOW_HASKELL__ > 504 hiding (getEnv) diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index 7df178d..d87c2bb 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -28,12 +28,8 @@ import ByteCodeItbls ( ItblEnv ) import ByteCodeAsm ( CompiledByteCode(..), bcoFreeNames, UnlinkedBCO(..)) import Packages -import DriverState ( v_Library_paths, v_Opt_l, v_Ld_inputs, getStaticOpts ) import DriverPhases ( isObjectFilename, isDynLibFilename ) -import DriverUtil ( getFileSuffix ) -#ifdef darwin_TARGET_OS -import DriverState ( v_Cmdline_frameworks, v_Framework_paths ) -#endif +import Util ( getFileSuffix ) import Finder ( findModule, findLinkable, FindResult(..) ) import HscTypes import Name ( Name, nameModule, isExternalName, isWiredInName ) @@ -41,7 +37,7 @@ import NameEnv import NameSet ( nameSetToList ) import Module import ListSetOps ( minusList ) -import CmdLineOpts ( DynFlags(..) ) +import DynFlags ( DynFlags(..) ) import BasicTypes ( SuccessFlag(..), succeeded, failed ) import Outputable import Panic ( GhcException(..) ) diff --git a/ghc/compiler/ghci/ObjLink.lhs b/ghc/compiler/ghci/ObjLink.lhs index 6994a21..0feb26b 100644 --- a/ghc/compiler/ghci/ObjLink.lhs +++ b/ghc/compiler/ghci/ObjLink.lhs @@ -25,7 +25,6 @@ import Monad ( when ) import Foreign.C import Foreign ( Ptr, nullPtr ) import Panic ( panic ) -import DriverUtil ( prefixUnderscore ) import BasicTypes ( SuccessFlag, successIf ) import Outputable @@ -42,6 +41,11 @@ lookupSymbol str_in = do then return Nothing else return (Just addr) +prefixUnderscore :: String -> String +prefixUnderscore + | cLeadingUnderscore == "YES" = ('_':) + | otherwise = id + loadDLL :: String -> IO (Maybe String) -- Nothing => success -- Just err_msg => failure diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 03d414a..257b940 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -41,7 +41,7 @@ import OccName ( mkVarOcc ) import BasicTypes ( IPName, Boxity, tupleParens ) import PrelNames ( unboundKey ) import SrcLoc ( noSrcLoc, Located(..), unLoc, noSrcSpan ) -import CmdLineOpts ( opt_PprStyle_Debug ) +import StaticFlags ( opt_PprStyle_Debug ) import Outputable \end{code} diff --git a/ghc/compiler/iface/BinIface.hs b/ghc/compiler/iface/BinIface.hs index b809e3a..11e6238 100644 --- a/ghc/compiler/iface/BinIface.hs +++ b/ghc/compiler/iface/BinIface.hs @@ -17,8 +17,7 @@ import VarEnv import Packages ( PackageIdH(..) ) import Class ( DefMeth(..) ) import CostCentre -import DriverState ( v_Build_tag ) -import CmdLineOpts ( opt_HiVersion ) +import StaticFlags ( opt_HiVersion, v_Build_tag ) import Kind ( Kind(..) ) import Panic import Binary diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index a760b83..25d0508 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -17,8 +17,8 @@ module LoadIface ( import {-# SOURCE #-} TcIface( tcIfaceDecl ) import Packages ( PackageState(..), PackageIdH(..), isHomePackage ) -import DriverState ( v_GhcMode, isCompManagerMode ) -import CmdLineOpts ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) ) +import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ), + isOneShot ) import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceInst(..), IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..), @@ -607,8 +607,7 @@ findHiFile dflags explicit mod_name hi_boot_file -- This helps in the case where you are sitting in eg. ghc/lib/std -- and start up GHCi - it won't complain that all the modules it tries -- to load are found in the home location. - ghci_mode <- readIORef v_GhcMode ; - let { home_allowed = not (isCompManagerMode ghci_mode) } ; + let { home_allowed = isOneShot (ghcMode dflags) } ; maybe_found <- if home_allowed then findModule dflags mod_name explicit else findPackageModule dflags mod_name explicit; diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index 354e31e..c21a9ad 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -187,8 +187,7 @@ import TcRnTypes ( mkModDeps ) import TcType ( isFFITy ) import HscTypes ( ModIface(..), TyThing(..), ModGuts(..), ModGuts, IfaceExport, - GhciMode(..), HscEnv(..), hscEPS, - Dependencies(..), FixItem(..), + HscEnv(..), hscEPS, Dependencies(..), FixItem(..), ModSummary(..), msHiFilePath, mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache, typeEnvElts, @@ -200,7 +199,8 @@ import HscTypes ( ModIface(..), TyThing(..), ) -import CmdLineOpts +import DynFlags ( GhcMode(..), DynFlags(..), DynFlag(..), dopt ) +import StaticFlags ( opt_HiVersion ) import Name ( Name, nameModule, nameOccName, nameParent, isExternalName, nameParent_maybe, isWiredInName, NamedThing(..) ) @@ -221,7 +221,7 @@ import Module ( Module, moduleFS, extendModuleEnv_C ) import Outputable -import DriverUtil ( createDirectoryHierarchy, directoryOf ) +import Util ( createDirectoryHierarchy, directoryOf ) import Util ( sortLe, seqList ) import Binary ( getBinFileWithDict ) import BinIface ( writeBinIface, v_IgnoreHiWay ) @@ -346,7 +346,7 @@ mkIface hsc_env location maybe_old_iface i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2 dflags = hsc_dflags hsc_env - ghci_mode = hsc_mode hsc_env + ghci_mode = ghcMode (hsc_dflags hsc_env) omit_prags = dopt Opt_OmitInterfacePragmas dflags hi_file_path = ml_hi_file location diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index a75582a..a2cfbed 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -62,7 +62,7 @@ import ErrUtils ( Message ) import Maybes ( MaybeErr(..) ) import SrcLoc ( noSrcLoc ) import Util ( zipWithEqual, dropList, equalLength ) -import CmdLineOpts ( DynFlag(..) ) +import DynFlags ( DynFlag(..) ) \end{code} This module takes diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index 8d6c915..66d9b02 100644 --- a/ghc/compiler/ilxGen/IlxGen.lhs +++ b/ghc/compiler/ilxGen/IlxGen.lhs @@ -50,7 +50,7 @@ import TysPrim ( foreignObjPrimTyCon, weakPrimTyCon, byteArrayPrimTyCon, mutabl -- versions of compiled Haskell code. We add a ".O" to all assembly and module -- names when this is set (because that's clue that -O was set). -- One day this will be configured by the command line. -import CmdLineOpts ( opt_InPackage, opt_SimplDoEtaReduction ) +import DynFlags ( opt_InPackage, opt_SimplDoEtaReduction ) import Util ( lengthIs, equalLength ) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs deleted file mode 100644 index cf7fd7f..0000000 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ /dev/null @@ -1,855 +0,0 @@ - -% (c) The University of Glasgow, 1996-2000 -% -\section[CmdLineOpts]{Things to do with command-line options} - -\begin{code} - -module CmdLineOpts ( - CoreToDo(..), buildCoreToDo, StgToDo(..), - SimplifierSwitch(..), - SimplifierMode(..), FloatOutSwitches(..), - - HscTarget(..), - DynFlag(..), -- needed non-abstractly by DriverFlags - DynFlags(..), - PackageFlag(..), - - v_Static_hsc_opts, - - isStaticHscFlag, - - -- Manipulating DynFlags - defaultDynFlags, -- DynFlags - dopt, -- DynFlag -> DynFlags -> Bool - dopt_set, dopt_unset, -- DynFlags -> DynFlag -> DynFlags - dopt_CoreToDo, -- DynFlags -> [CoreToDo] - dopt_StgToDo, -- DynFlags -> [StgToDo] - dopt_HscTarget, -- DynFlags -> HscTarget - dopt_OutName, -- DynFlags -> String - getOpts, -- (DynFlags -> [a]) -> IO [a] - getVerbFlag, - updOptLevel, - - -- sets of warning opts - minusWOpts, - minusWallOpts, - - -- Output style options - opt_PprUserLength, - opt_PprStyle_Debug, - - -- profiling opts - opt_AutoSccsOnAllToplevs, - opt_AutoSccsOnExportedToplevs, - opt_AutoSccsOnIndividualCafs, - opt_SccProfilingOn, - opt_DoTickyProfiling, - - -- language opts - opt_DictsStrict, - opt_MaxContextReductionDepth, - opt_IrrefutableTuples, - opt_Parallel, - opt_SMP, - opt_RuntimeTypes, - opt_Flatten, - - -- optimisation opts - opt_NoMethodSharing, - opt_NoStateHack, - opt_LiberateCaseThreshold, - opt_CprOff, - opt_RulesOff, - opt_SimplNoPreInlining, - opt_SimplExcessPrecision, - opt_MaxWorkerArgs, - - -- Unfolding control - opt_UF_CreationThreshold, - opt_UF_UseThreshold, - opt_UF_FunAppDiscount, - opt_UF_KeenessFactor, - opt_UF_UpdateInPlace, - opt_UF_DearOp, - - -- misc opts - opt_ErrorSpans, - opt_EmitCExternDecls, - opt_EnsureSplittableC, - opt_GranMacros, - opt_HiVersion, - opt_HistorySize, - opt_OmitBlackHoling, - opt_Static, - opt_Unregisterised, - opt_EmitExternalCore, - opt_PIC - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} Packages (PackageState) -import DriverPhases ( HscTarget(..) ) -import Constants -- Default values for some flags -import Util -import FastString ( FastString, mkFastString ) -import Config -import Maybes ( firstJust ) - -import Panic ( ghcError, GhcException(UsageError) ) -import GLAEXTS -import DATA_IOREF ( IORef, readIORef ) -import UNSAFE_IO ( unsafePerformIO ) -\end{code} - -%************************************************************************ -%* * -\subsection{Command-line options} -%* * -%************************************************************************ - -The hsc command-line options are split into two categories: - - - static flags - - dynamic flags - -Static flags are represented by top-level values of type Bool or Int, -for example. They therefore have the same value throughout the -invocation of hsc. - -Dynamic flags are represented by an abstract type, DynFlags, which is -passed into hsc by the compilation manager for every compilation. -Dynamic flags are those that change on a per-compilation basis, -perhaps because they may be present in the OPTIONS pragma at the top -of a module. - -Other flag-related blurb: - -A list of {\em ToDo}s is things to be done in a particular part of -processing. A (fictitious) example for the Core-to-Core simplifier -might be: run the simplifier, then run the strictness analyser, then -run the simplifier again (three ``todos''). - -There are three ``to-do processing centers'' at the moment. In the -main loop (\tr{main/Main.lhs}), in the Core-to-Core processing loop -(\tr{simplCore/SimplCore.lhs), and in the STG-to-STG processing loop -(\tr{simplStg/SimplStg.lhs}). - -%************************************************************************ -%* * -\subsection{Datatypes associated with command-line options} -%* * -%************************************************************************ - -\begin{code} -data CoreToDo -- These are diff core-to-core passes, - -- which may be invoked in any order, - -- as many times as you like. - - = CoreDoSimplify -- The core-to-core simplifier. - SimplifierMode - [SimplifierSwitch] - -- Each run of the simplifier can take a different - -- set of simplifier-specific flags. - | CoreDoFloatInwards - | CoreDoFloatOutwards FloatOutSwitches - | CoreLiberateCase - | CoreDoPrintCore - | CoreDoStaticArgs - | CoreDoStrictness - | CoreDoWorkerWrapper - | CoreDoSpecialising - | CoreDoSpecConstr - | CoreDoOldStrictness - | CoreDoGlomBinds - | CoreCSE - | CoreDoRuleCheck Int{-CompilerPhase-} String -- Check for non-application of rules - -- matching this string - - | CoreDoNothing -- useful when building up lists of these things -\end{code} - -\begin{code} -data StgToDo - = StgDoMassageForProfiling -- should be (next to) last - -- There's also setStgVarInfo, but its absolute "lastness" - -- is so critical that it is hardwired in (no flag). - | D_stg_stats -\end{code} - -\begin{code} -data SimplifierMode -- See comments in SimplMonad - = SimplGently - | SimplPhase Int - -data SimplifierSwitch - = MaxSimplifierIterations Int - | NoCaseOfCase - -data FloatOutSwitches - = FloatOutSw Bool -- True <=> float lambdas to top level - Bool -- True <=> float constants to top level, - -- even if they do not escape a lambda -\end{code} - -%************************************************************************ -%* * -\subsection{Dynamic command-line options} -%* * -%************************************************************************ - -\begin{code} -data DynFlag - - -- debugging flags - = Opt_D_dump_cmm - | Opt_D_dump_asm - | Opt_D_dump_cpranal - | Opt_D_dump_deriv - | Opt_D_dump_ds - | Opt_D_dump_flatC - | Opt_D_dump_foreign - | Opt_D_dump_inlinings - | Opt_D_dump_occur_anal - | Opt_D_dump_parsed - | Opt_D_dump_rn - | Opt_D_dump_simpl - | Opt_D_dump_simpl_iterations - | Opt_D_dump_spec - | Opt_D_dump_prep - | Opt_D_dump_stg - | Opt_D_dump_stranal - | Opt_D_dump_tc - | Opt_D_dump_types - | Opt_D_dump_rules - | Opt_D_dump_cse - | Opt_D_dump_worker_wrapper - | Opt_D_dump_rn_trace - | Opt_D_dump_rn_stats - | Opt_D_dump_opt_cmm - | Opt_D_dump_simpl_stats - | Opt_D_dump_tc_trace - | Opt_D_dump_if_trace - | Opt_D_dump_splices - | Opt_D_dump_BCOs - | Opt_D_dump_vect - | Opt_D_source_stats - | Opt_D_verbose_core2core - | Opt_D_verbose_stg2stg - | Opt_D_dump_hi - | Opt_D_dump_hi_diffs - | Opt_D_dump_minimal_imports - | Opt_DoCoreLinting - | Opt_DoStgLinting - | Opt_DoCmmLinting - - | Opt_WarnIsError -- -Werror; makes warnings fatal - | Opt_WarnDuplicateExports - | Opt_WarnHiShadows - | Opt_WarnIncompletePatterns - | Opt_WarnIncompletePatternsRecUpd - | Opt_WarnMissingFields - | Opt_WarnMissingMethods - | Opt_WarnMissingSigs - | Opt_WarnNameShadowing - | Opt_WarnOverlappingPatterns - | Opt_WarnSimplePatterns - | Opt_WarnTypeDefaults - | Opt_WarnUnusedBinds - | Opt_WarnUnusedImports - | Opt_WarnUnusedMatches - | Opt_WarnDeprecations - | Opt_WarnDodgyImports - | Opt_WarnOrphans - - -- language opts - | Opt_AllowOverlappingInstances - | Opt_AllowUndecidableInstances - | Opt_AllowIncoherentInstances - | Opt_MonomorphismRestriction - | Opt_GlasgowExts - | Opt_FFI - | Opt_PArr -- syntactic support for parallel arrays - | Opt_Arrows -- Arrow-notation syntax - | Opt_TH - | Opt_ImplicitParams - | Opt_Generics - | Opt_ImplicitPrelude - | Opt_ScopedTypeVariables - - -- optimisation opts - | Opt_Strictness - | Opt_FullLaziness - | Opt_CSE - | Opt_IgnoreInterfacePragmas - | Opt_OmitInterfacePragmas - | Opt_DoLambdaEtaExpansion - | Opt_IgnoreAsserts - | Opt_DoEtaReduction - | Opt_CaseMerge - | Opt_UnboxStrictFields - - deriving (Eq) - -data DynFlags = DynFlags { - coreToDo :: Maybe [CoreToDo], -- reserved for use with -Ofile - stgToDo :: [StgToDo], - hscTarget :: HscTarget, - hscOutName :: String, -- name of the output file - hscStubHOutName :: String, -- name of the .stub_h output file - hscStubCOutName :: String, -- name of the .stub_c output file - extCoreName :: String, -- name of the .core output file - verbosity :: Int, -- verbosity level - optLevel :: Int, -- optimisation level - maxSimplIterations :: Int, -- max simplifier iterations - ruleCheck :: Maybe String, - cppFlag :: Bool, -- preprocess with cpp? - ppFlag :: Bool, -- preprocess with a Haskell Pp? - recompFlag :: Bool, -- True <=> recompilation checker is on - stolen_x86_regs :: Int, - cmdlineHcIncludes :: [String], -- -#includes - importPaths :: [FilePath], - - -- options for particular phases - opt_L :: [String], - opt_P :: [String], - opt_F :: [String], - opt_c :: [String], - opt_a :: [String], - opt_m :: [String], -#ifdef ILX - opt_I :: [String], - opt_i :: [String], -#endif - - -- ** Package flags - extraPkgConfs :: [FilePath], - -- The -package-conf flags given on the command line, in the order - -- they appeared. - - readUserPkgConf :: Bool, - -- Whether or not to read the user package database - -- (-no-user-package-conf). - - packageFlags :: [PackageFlag], - -- The -package and -hide-package flags from the command-line - - -- ** Package state - pkgState :: PackageState, - - -- hsc dynamic flags - flags :: [DynFlag] - } - -data PackageFlag - = ExposePackage String - | HidePackage String - | IgnorePackage String - -defaultHscTarget -#if defined(i386_TARGET_ARCH) || defined(sparc_TARGET_ARCH) || defined(powerpc_TARGET_ARCH) - | cGhcWithNativeCodeGen == "YES" = HscAsm -#endif - | otherwise = HscC - -defaultDynFlags = DynFlags { - coreToDo = Nothing, stgToDo = [], - hscTarget = defaultHscTarget, - hscOutName = "", - hscStubHOutName = "", hscStubCOutName = "", - extCoreName = "", - verbosity = 0, - optLevel = 0, - maxSimplIterations = 4, - ruleCheck = Nothing, - cppFlag = False, - ppFlag = False, - recompFlag = True, - stolen_x86_regs = 4, - cmdlineHcIncludes = [], - importPaths = ["."], - opt_L = [], - opt_P = [], - opt_F = [], - opt_c = [], - opt_a = [], - opt_m = [], -#ifdef ILX - opt_I = [], - opt_i = [], -#endif - - extraPkgConfs = [], - readUserPkgConf = True, - packageFlags = [], - pkgState = error "pkgState", - - flags = [ - Opt_ImplicitPrelude, - Opt_MonomorphismRestriction, - Opt_Strictness, - -- strictness is on by default, but this only - -- applies to -O. - Opt_CSE, -- similarly for CSE. - Opt_FullLaziness, -- ...and for full laziness - - Opt_DoLambdaEtaExpansion, - -- This one is important for a tiresome reason: - -- we want to make sure that the bindings for data - -- constructors are eta-expanded. This is probably - -- a good thing anyway, but it seems fragile. - - -- and the default no-optimisation options: - Opt_IgnoreInterfacePragmas, - Opt_OmitInterfacePragmas - - ] ++ standardWarnings - } - -{- - Verbosity levels: - - 0 | print errors & warnings only - 1 | minimal verbosity: print "compiling M ... done." for each module. - 2 | equivalent to -dshow-passes - 3 | equivalent to existing "ghc -v" - 4 | "ghc -v -ddump-most" - 5 | "ghc -v -ddump-all" --} - -dopt :: DynFlag -> DynFlags -> Bool -dopt f dflags = f `elem` (flags dflags) - -dopt_CoreToDo :: DynFlags -> Maybe [CoreToDo] -dopt_CoreToDo = coreToDo - -dopt_StgToDo :: DynFlags -> [StgToDo] -dopt_StgToDo = stgToDo - -dopt_OutName :: DynFlags -> String -dopt_OutName = hscOutName - -dopt_HscTarget :: DynFlags -> HscTarget -dopt_HscTarget = hscTarget - -dopt_set :: DynFlags -> DynFlag -> DynFlags -dopt_set dfs f = dfs{ flags = f : flags dfs } - -dopt_unset :: DynFlags -> DynFlag -> DynFlags -dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) } - -getOpts :: DynFlags -> (DynFlags -> [a]) -> [a] - -- We add to the options from the front, so we need to reverse the list -getOpts dflags opts = reverse (opts dflags) - -getVerbFlag dflags - | verbosity dflags >= 3 = "-v" - | otherwise = "" - ------------------------------------------------------------------------------ --- Setting the optimisation level - -updOptLevel :: Int -> DynFlags -> DynFlags --- Set dynflags appropriate to the optimisation level -updOptLevel n dfs - = if (n >= 1) - then dfs2{ hscTarget = HscC, optLevel = n } -- turn on -fvia-C with -O - else dfs2{ optLevel = n } - where - dfs1 = foldr (flip dopt_unset) dfs remove_dopts - dfs2 = foldr (flip dopt_set) dfs1 extra_dopts - - extra_dopts - | n == 0 = opt_0_dopts - | otherwise = opt_1_dopts - - remove_dopts - | n == 0 = opt_1_dopts - | otherwise = opt_0_dopts - -opt_0_dopts = [ - Opt_IgnoreInterfacePragmas, - Opt_OmitInterfacePragmas - ] - -opt_1_dopts = [ - Opt_IgnoreAsserts, - Opt_DoEtaReduction, - Opt_CaseMerge - ] - --- Core-to-core phases: - -buildCoreToDo :: DynFlags -> [CoreToDo] -buildCoreToDo dflags = core_todo - where - opt_level = optLevel dflags - max_iter = maxSimplIterations dflags - strictness = dopt Opt_Strictness dflags - full_laziness = dopt Opt_FullLaziness dflags - cse = dopt Opt_CSE dflags - rule_check = ruleCheck dflags - - core_todo = - if opt_level == 0 then - [ - CoreDoSimplify (SimplPhase 0) [ - MaxSimplifierIterations max_iter - ] - ] - - else {- opt_level >= 1 -} [ - - -- initial simplify: mk specialiser happy: minimum effort please - CoreDoSimplify SimplGently [ - -- Simplify "gently" - -- Don't inline anything till full laziness has bitten - -- In particular, inlining wrappers inhibits floating - -- e.g. ...(case f x of ...)... - -- ==> ...(case (case x of I# x# -> fw x#) of ...)... - -- ==> ...(case x of I# x# -> case fw x# of ...)... - -- and now the redex (f x) isn't floatable any more - -- Similarly, don't apply any rules until after full - -- laziness. Notably, list fusion can prevent floating. - - NoCaseOfCase, - -- Don't do case-of-case transformations. - -- This makes full laziness work better - MaxSimplifierIterations max_iter - ], - - -- Specialisation is best done before full laziness - -- so that overloaded functions have all their dictionary lambdas manifest - CoreDoSpecialising, - - if full_laziness then CoreDoFloatOutwards (FloatOutSw False False) - else CoreDoNothing, - - CoreDoFloatInwards, - - CoreDoSimplify (SimplPhase 2) [ - -- Want to run with inline phase 2 after the specialiser to give - -- maximum chance for fusion to work before we inline build/augment - -- in phase 1. This made a difference in 'ansi' where an - -- overloaded function wasn't inlined till too late. - MaxSimplifierIterations max_iter - ], - case rule_check of { Just pat -> CoreDoRuleCheck 2 pat; Nothing -> CoreDoNothing }, - - CoreDoSimplify (SimplPhase 1) [ - -- Need inline-phase2 here so that build/augment get - -- inlined. I found that spectral/hartel/genfft lost some useful - -- strictness in the function sumcode' if augment is not inlined - -- before strictness analysis runs - MaxSimplifierIterations max_iter - ], - case rule_check of { Just pat -> CoreDoRuleCheck 1 pat; Nothing -> CoreDoNothing }, - - CoreDoSimplify (SimplPhase 0) [ - -- Phase 0: allow all Ids to be inlined now - -- This gets foldr inlined before strictness analysis - - MaxSimplifierIterations 3 - -- At least 3 iterations because otherwise we land up with - -- huge dead expressions because of an infelicity in the - -- simpifier. - -- let k = BIG in foldr k z xs - -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs - -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs - -- Don't stop now! - - ], - case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing }, - -#ifdef OLD_STRICTNESS - CoreDoOldStrictness -#endif - if strictness then CoreDoStrictness else CoreDoNothing, - CoreDoWorkerWrapper, - CoreDoGlomBinds, - - CoreDoSimplify (SimplPhase 0) [ - MaxSimplifierIterations max_iter - ], - - if full_laziness then - CoreDoFloatOutwards (FloatOutSw False -- Not lambdas - True) -- Float constants - else CoreDoNothing, - -- nofib/spectral/hartel/wang doubles in speed if you - -- do full laziness late in the day. It only happens - -- after fusion and other stuff, so the early pass doesn't - -- catch it. For the record, the redex is - -- f_el22 (f_el21 r_midblock) - - - -- We want CSE to follow the final full-laziness pass, because it may - -- succeed in commoning up things floated out by full laziness. - -- CSE used to rely on the no-shadowing invariant, but it doesn't any more - - if cse then CoreCSE else CoreDoNothing, - - CoreDoFloatInwards, - --- Case-liberation for -O2. This should be after --- strictness analysis and the simplification which follows it. - - case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing }, - - if opt_level >= 2 then - CoreLiberateCase - else - CoreDoNothing, - if opt_level >= 2 then - CoreDoSpecConstr - else - CoreDoNothing, - - -- Final clean-up simplification: - CoreDoSimplify (SimplPhase 0) [ - MaxSimplifierIterations max_iter - ] - ] -\end{code} - -%************************************************************************ -%* * -\subsection{Warnings} -%* * -%************************************************************************ - -\begin{code} -standardWarnings - = [ Opt_WarnDeprecations, - Opt_WarnOverlappingPatterns, - Opt_WarnMissingFields, - Opt_WarnMissingMethods, - Opt_WarnDuplicateExports - ] - -minusWOpts - = standardWarnings ++ - [ Opt_WarnUnusedBinds, - Opt_WarnUnusedMatches, - Opt_WarnUnusedImports, - Opt_WarnIncompletePatterns, - Opt_WarnDodgyImports - ] - -minusWallOpts - = minusWOpts ++ - [ Opt_WarnTypeDefaults, - Opt_WarnNameShadowing, - Opt_WarnMissingSigs, - Opt_WarnHiShadows, - Opt_WarnOrphans - ] -\end{code} - -%************************************************************************ -%* * -\subsection{Classifying command-line options} -%* * -%************************************************************************ - -\begin{code} --- v_Statis_hsc_opts is here to avoid a circular dependency with --- main/DriverState. -GLOBAL_VAR(v_Static_hsc_opts, [], [String]) - -lookUp :: FastString -> Bool -lookup_def_int :: String -> Int -> Int -lookup_def_float :: String -> Float -> Float -lookup_str :: String -> Maybe String - -unpacked_static_opts = unsafePerformIO (readIORef v_Static_hsc_opts) -packed_static_opts = map mkFastString unpacked_static_opts - -lookUp sw = sw `elem` packed_static_opts - --- (lookup_str "foo") looks for the flag -foo=X or -fooX, --- and returns the string X -lookup_str sw - = case firstJust (map (startsWith sw) unpacked_static_opts) of - Just ('=' : str) -> Just str - Just str -> Just str - Nothing -> Nothing - -lookup_def_int sw def = case (lookup_str sw) of - Nothing -> def -- Use default - Just xx -> try_read sw xx - -lookup_def_float sw def = case (lookup_str sw) of - Nothing -> def -- Use default - Just xx -> try_read sw xx - - -try_read :: Read a => String -> String -> a --- (try_read sw str) tries to read s; if it fails, it --- bleats about flag sw -try_read sw str - = case reads str of - ((x,_):_) -> x -- Be forgiving: ignore trailing goop, and alternative parses - [] -> ghcError (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw)) - -- ToDo: hack alert. We should really parse the arugments - -- and announce errors in a more civilised way. - - -{- - Putting the compiler options into temporary at-files - may turn out to be necessary later on if we turn hsc into - a pure Win32 application where I think there's a command-line - length limit of 255. unpacked_opts understands the @ option. - -unpacked_opts :: [String] -unpacked_opts = - concat $ - map (expandAts) $ - map unpackFS argv -- NOT ARGV any more: v_Static_hsc_opts - where - expandAts ('@':fname) = words (unsafePerformIO (readFile fname)) - expandAts l = [l] --} -\end{code} - -%************************************************************************ -%* * -\subsection{Static options} -%* * -%************************************************************************ - -\begin{code} --- debugging opts -opt_PprStyle_Debug = lookUp FSLIT("-dppr-debug") -opt_PprUserLength = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name - --- profiling opts -opt_AutoSccsOnAllToplevs = lookUp FSLIT("-fauto-sccs-on-all-toplevs") -opt_AutoSccsOnExportedToplevs = lookUp FSLIT("-fauto-sccs-on-exported-toplevs") -opt_AutoSccsOnIndividualCafs = lookUp FSLIT("-fauto-sccs-on-individual-cafs") -opt_SccProfilingOn = lookUp FSLIT("-fscc-profiling") -opt_DoTickyProfiling = lookUp FSLIT("-fticky-ticky") - --- language opts -opt_DictsStrict = lookUp FSLIT("-fdicts-strict") -opt_IrrefutableTuples = lookUp FSLIT("-firrefutable-tuples") -opt_MaxContextReductionDepth = lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH -opt_Parallel = lookUp FSLIT("-fparallel") -opt_SMP = lookUp FSLIT("-fsmp") -opt_Flatten = lookUp FSLIT("-fflatten") - --- optimisation opts -opt_NoStateHack = lookUp FSLIT("-fno-state-hack") -opt_NoMethodSharing = lookUp FSLIT("-fno-method-sharing") -opt_CprOff = lookUp FSLIT("-fcpr-off") -opt_RulesOff = lookUp FSLIT("-frules-off") - -- Switch off CPR analysis in the new demand analyser -opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" (10::Int) -opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int) - -opt_EmitCExternDecls = lookUp FSLIT("-femit-extern-decls") -opt_EnsureSplittableC = lookUp FSLIT("-fglobalise-toplev-names") -opt_GranMacros = lookUp FSLIT("-fgransim") -opt_HiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Int -opt_HistorySize = lookup_def_int "-fhistory-size" 20 -opt_OmitBlackHoling = lookUp FSLIT("-dno-black-holing") -opt_RuntimeTypes = lookUp FSLIT("-fruntime-types") - --- Simplifier switches -opt_SimplNoPreInlining = lookUp FSLIT("-fno-pre-inlining") - -- NoPreInlining is there just to see how bad things - -- get if you don't do it! -opt_SimplExcessPrecision = lookUp FSLIT("-fexcess-precision") - --- Unfolding control -opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (45::Int) -opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (8::Int) -- Discounts can be big -opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int) -- It's great to inline a fn -opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float) -opt_UF_UpdateInPlace = lookUp FSLIT("-funfolding-update-in-place") - -opt_UF_DearOp = ( 4 :: Int) - -opt_Static = lookUp FSLIT("-static") -opt_Unregisterised = lookUp FSLIT("-funregisterised") -opt_EmitExternalCore = lookUp FSLIT("-fext-core") - --- Include full span info in error messages, instead of just the start position. -opt_ErrorSpans = lookUp FSLIT("-ferror-spans") - -opt_PIC = lookUp FSLIT("-fPIC") -\end{code} - -%************************************************************************ -%* * -\subsection{List of static hsc flags} -%* * -%************************************************************************ - -\begin{code} -isStaticHscFlag f = - f `elem` [ - "fauto-sccs-on-all-toplevs", - "fauto-sccs-on-exported-toplevs", - "fauto-sccs-on-individual-cafs", - "fauto-sccs-on-dicts", - "fscc-profiling", - "fticky-ticky", - "fall-strict", - "fdicts-strict", - "firrefutable-tuples", - "fparallel", - "fsmp", - "fflatten", - "fsemi-tagging", - "flet-no-escape", - "femit-extern-decls", - "fglobalise-toplev-names", - "fgransim", - "fno-hi-version-check", - "dno-black-holing", - "fno-method-sharing", - "fno-state-hack", - "fruntime-types", - "fno-pre-inlining", - "fexcess-precision", - "funfolding-update-in-place", - "static", - "funregisterised", - "fext-core", - "frule-check", - "frules-off", - "fcpr-off", - "ferror-spans", - "fPIC" - ] - || any (flip prefixMatch f) [ - "fcontext-stack", - "fliberate-case-threshold", - "fmax-worker-args", - "fhistory-size", - "funfolding-creation-threshold", - "funfolding-use-threshold", - "funfolding-fun-discount", - "funfolding-keeness-factor" - ] -\end{code} - -%************************************************************************ -%* * -\subsection{Misc functions for command-line options} -%* * -%************************************************************************ - - - -\begin{code} -startsWith :: String -> String -> Maybe String --- startsWith pfx (pfx++rest) = Just rest - -startsWith [] str = Just str -startsWith (c:cs) (s:ss) - = if c /= s then Nothing else startsWith cs ss -startsWith _ [] = Nothing -\end{code} diff --git a/ghc/compiler/main/CmdLineParser.hs b/ghc/compiler/main/CmdLineParser.hs new file mode 100644 index 0000000..dd22348 --- /dev/null +++ b/ghc/compiler/main/CmdLineParser.hs @@ -0,0 +1,136 @@ +----------------------------------------------------------------------------- +-- +-- Command-line parser +-- +-- This is an abstract command-line parser used by both StaticFlags and +-- DynFlags. +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module CmdLineParser ( + processArgs, OptKind(..), + CmdLineP(..), getCmdLineState, putCmdLineState + ) where + +#include "HsVersions.h" + +import Util ( maybePrefixMatch, notNull, removeSpaces ) + +data OptKind m + = NoArg (m ()) -- flag with no argument + | HasArg (String -> m ()) -- flag has an argument (maybe prefix) + | SepArg (String -> m ()) -- flag has a separate argument + | Prefix (String -> m ()) -- flag is a prefix only + | OptPrefix (String -> m ()) -- flag may be a prefix + | AnySuffix (String -> m ()) -- flag is a prefix, pass whole arg to fn + | PassFlag (String -> m ()) -- flag with no arg, pass flag to fn + | PrefixPred (String -> Bool) (String -> m ()) + | AnySuffixPred (String -> Bool) (String -> m ()) + +processArgs :: Monad m + => [(String, OptKind m)] -- cmdline parser spec + -> [String] -- args + -> m ( + [String], -- spare args + [String] -- errors + ) +processArgs spec args = process spec args [] [] + where + process _spec [] spare errs = + return (reverse spare, reverse errs) + + process spec args@(('-':arg):args') spare errs = + case findArg spec arg of + Just (rest,action) -> + case processOneArg action rest args of + Left err -> process spec args' spare (err:errs) + Right (action,rest) -> do + action >> process spec rest spare errs + Nothing -> + process spec args' (('-':arg):spare) errs + + process spec (arg:args) spare errs = + process spec args (arg:spare) errs + + +processOneArg :: OptKind m -> String -> [String] + -> Either String (m (), [String]) +processOneArg action rest (dash_arg@('-':arg):args) = + case action of + NoArg a -> ASSERT(null rest) Right (a, args) + + HasArg f -> + if rest /= "" + then Right (f rest, args) + else case args of + [] -> missingArgErr dash_arg + (arg1:args1) -> Right (f arg1, args1) + + SepArg f -> + case args of + [] -> unknownFlagErr dash_arg + (arg1:args1) -> Right (f arg1, args1) + + Prefix f -> + if rest /= "" + then Right (f rest, args) + else unknownFlagErr dash_arg + + PrefixPred p f -> + if rest /= "" + then Right (f rest, args) + else unknownFlagErr dash_arg + + OptPrefix f -> Right (f rest, args) + + AnySuffix f -> Right (f dash_arg, args) + + AnySuffixPred p f -> Right (f dash_arg, args) + + PassFlag f -> + if rest /= "" + then unknownFlagErr dash_arg + else Right (f dash_arg, args) + + +findArg :: [(String,OptKind a)] -> String -> Maybe (String,OptKind a) +findArg spec arg + = case [ (removeSpaces rest, k) + | (pat,k) <- spec, + Just rest <- [maybePrefixMatch pat arg], + arg_ok k rest arg ] + of + [] -> Nothing + (one:_) -> Just one + +arg_ok (NoArg _) rest arg = null rest +arg_ok (HasArg _) rest arg = True +arg_ok (SepArg _) rest arg = null rest +arg_ok (Prefix _) rest arg = notNull rest +arg_ok (PrefixPred p _) rest arg = notNull rest && p rest +arg_ok (OptPrefix _) rest arg = True +arg_ok (PassFlag _) rest arg = null rest +arg_ok (AnySuffix _) rest arg = True +arg_ok (AnySuffixPred p _) rest arg = p arg + +unknownFlagErr :: String -> Either String a +unknownFlagErr f = Left ("unrecognised flag: " ++ f) + +missingArgErr :: String -> Either String a +missingArgErr f = Left ("missing argument for flag: " ++ f) + +-- ----------------------------------------------------------------------------- +-- A state monad for use in the command-line parser + +newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) } + +instance Monad (CmdLineP s) where + return a = CmdLineP $ \s -> (a, s) + m >>= k = CmdLineP $ \s -> let + (a, s') = runCmdLine m s + in runCmdLine (k a) s' + +getCmdLineState = CmdLineP $ \s -> (s,s) +putCmdLineState s = CmdLineP $ \_ -> ((),s) diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index b01b668..704a908 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -27,11 +27,11 @@ import Distribution.Package ( showPackageId ) import PprC ( writeCs ) import CmmLint ( cmmLint ) import Packages -import DriverUtil ( filenameOf ) +import Util ( filenameOf ) import FastString ( unpackFS ) import Cmm ( Cmm ) import HscTypes -import CmdLineOpts +import DynFlags import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable import Pretty ( Mode(..), printDoc ) @@ -77,9 +77,9 @@ codeOutput dflags this_mod foreign_stubs deps flat_abstractC } ; showPass dflags "CodeOutput" - ; let filenm = dopt_OutName dflags + ; let filenm = hscOutName dflags ; stubs_exist <- outputForeignStubs dflags foreign_stubs - ; case dopt_HscTarget dflags of { + ; case hscTarget dflags of { HscInterpreted -> return (); HscAsm -> outputAsm dflags filenm flat_abstractC; HscC -> outputC dflags filenm flat_abstractC stubs_exist diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs deleted file mode 100644 index f0f60f7..0000000 --- a/ghc/compiler/main/DriverFlags.hs +++ /dev/null @@ -1,767 +0,0 @@ ------------------------------------------------------------------------------ --- --- Driver flags --- --- (c) The University of Glasgow 2000-2003 --- ------------------------------------------------------------------------------ - -module DriverFlags ( - processDynamicFlags, - processStaticFlags, - - addCmdlineHCInclude, - buildStaticHscOpts, - machdepCCOpts, - picCCOpts, - - processArgs, OptKind(..), -- for DriverMkDepend only - ) where - -#include "HsVersions.h" - -import MkIface ( showIface ) -import DriverState -import DriverPhases -import DriverUtil -import SysTools -import CmdLineOpts -import Config -import Util -import Panic -import FastString ( mkFastString ) - -import EXCEPTION -import DATA_IOREF ( IORef, readIORef, writeIORef ) - -import System ( exitWith, ExitCode(..) ) -import IO -import Maybe -import Monad -import Char - ------------------------------------------------------------------------------ --- Flags - --- Flag parsing is now done in stages: --- --- * parse the initial list of flags and remove any flags understood --- by the driver only. Determine whether we're in multi-compilation --- or single-compilation mode (done in Main.main). --- --- * gather the list of "static" hsc flags, and assign them to the global --- static hsc flags variable. --- --- * build the inital DynFlags from the remaining flags. --- --- * complain if we've got any flags left over. --- --- * for each source file: grab the OPTIONS, and build a new DynFlags --- to pass to the compiler. - ------------------------------------------------------------------------------ --- Process command-line - -processStaticFlags :: [String] -> IO [String] -processStaticFlags opts = processArgs static_flags opts [] - -data OptKind - = NoArg (IO ()) -- flag with no argument - | HasArg (String -> IO ()) -- flag has an argument (maybe prefix) - | SepArg (String -> IO ()) -- flag has a separate argument - | Prefix (String -> IO ()) -- flag is a prefix only - | OptPrefix (String -> IO ()) -- flag may be a prefix - | AnySuffix (String -> IO ()) -- flag is a prefix, pass whole arg to fn - | PassFlag (String -> IO ()) -- flag with no arg, pass flag to fn - | PrefixPred (String -> Bool) (String -> IO ()) - | AnySuffixPred (String -> Bool) (String -> IO ()) - -processArgs :: [(String,OptKind)] -> [String] -> [String] - -> IO [String] -- returns spare args -processArgs _spec [] spare = return (reverse spare) - -processArgs spec args@(('-':arg):args') spare = do - case findArg spec arg of - Just (rest,action) -> do args' <- processOneArg action rest args - processArgs spec args' spare - Nothing -> processArgs spec args' (('-':arg):spare) - -processArgs spec (arg:args) spare = - processArgs spec args (arg:spare) - -processOneArg :: OptKind -> String -> [String] -> IO [String] -processOneArg action rest (dash_arg@('-':arg):args) = - case action of - NoArg io -> - if rest == "" - then io >> return args - else unknownFlagErr dash_arg - - HasArg fio -> - if rest /= "" - then fio rest >> return args - else case args of - [] -> missingArgErr dash_arg - (arg1:args1) -> fio arg1 >> return args1 - - SepArg fio -> - case args of - [] -> unknownFlagErr dash_arg - (arg1:args1) -> fio arg1 >> return args1 - - Prefix fio -> - if rest /= "" - then fio rest >> return args - else unknownFlagErr dash_arg - - PrefixPred p fio -> - if rest /= "" - then fio rest >> return args - else unknownFlagErr dash_arg - - OptPrefix fio -> fio rest >> return args - - AnySuffix fio -> fio dash_arg >> return args - - AnySuffixPred p fio -> fio dash_arg >> return args - - PassFlag fio -> - if rest /= "" - then unknownFlagErr dash_arg - else fio dash_arg >> return args - -findArg :: [(String,OptKind)] -> String -> Maybe (String,OptKind) -findArg spec arg - = case [ (remove_spaces rest, k) - | (pat,k) <- spec, - Just rest <- [maybePrefixMatch pat arg], - arg_ok k rest arg ] - of - [] -> Nothing - (one:_) -> Just one - -arg_ok (NoArg _) rest arg = null rest -arg_ok (HasArg _) rest arg = True -arg_ok (SepArg _) rest arg = null rest -arg_ok (Prefix _) rest arg = notNull rest -arg_ok (PrefixPred p _) rest arg = notNull rest && p rest -arg_ok (OptPrefix _) rest arg = True -arg_ok (PassFlag _) rest arg = null rest -arg_ok (AnySuffix _) rest arg = True -arg_ok (AnySuffixPred p _) rest arg = p arg - ------------------------------------------------------------------------------ --- Static flags - --- note that ordering is important in the following list: any flag which --- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override --- flags further down the list with the same prefix. - -static_flags = - [ ------- help / version ---------------------------------------------- - ( "?" , NoArg showGhcUsage) - , ( "-help" , NoArg showGhcUsage) - , ( "-print-libdir" , NoArg (do getTopDir >>= putStrLn - exitWith ExitSuccess)) - , ( "V" , NoArg showVersion) - , ( "-version" , NoArg showVersion) - , ( "-numeric-version", NoArg (do putStrLn cProjectVersion - exitWith ExitSuccess)) - - ------- interfaces ---------------------------------------------------- - , ( "-show-iface" , HasArg (\f -> do showIface f - exitWith ExitSuccess)) - - ------- verbosity ---------------------------------------------------- - , ( "n" , NoArg setDryRun ) - - ------- primary modes ------------------------------------------------ - , ( "M" , PassFlag (setMode DoMkDependHS)) - , ( "E" , PassFlag (setMode (StopBefore anyHsc))) - , ( "C" , PassFlag (\f -> do setMode (StopBefore HCc) f - setTarget HscC)) - , ( "S" , PassFlag (setMode (StopBefore As))) - , ( "-make" , PassFlag (setMode DoMake)) - , ( "-interactive" , PassFlag (setMode DoInteractive)) - , ( "-mk-dll" , NoArg (writeIORef v_GhcLink MkDLL)) - , ( "e" , HasArg (\s -> setMode (DoEval s) "-e")) - - -- -fno-code says to stop after Hsc but don't generate any code. - , ( "fno-code" , PassFlag (\f -> do setMode (StopBefore HCc) f - setTarget HscNothing - setRecompFlag False)) - - ------- GHCi ------------------------------------------------------- - , ( "ignore-dot-ghci", NoArg (writeIORef v_Read_DotGHCi False) ) - , ( "read-dot-ghci" , NoArg (writeIORef v_Read_DotGHCi True) ) - - ------- ways -------------------------------------------------------- - , ( "prof" , NoArg (addNoDups v_Ways WayProf) ) - , ( "unreg" , NoArg (addNoDups v_Ways WayUnreg) ) - , ( "ticky" , NoArg (addNoDups v_Ways WayTicky) ) - , ( "parallel" , NoArg (addNoDups v_Ways WayPar) ) - , ( "gransim" , NoArg (addNoDups v_Ways WayGran) ) - , ( "smp" , NoArg (addNoDups v_Ways WaySMP) ) - , ( "debug" , NoArg (addNoDups v_Ways WayDebug) ) - , ( "ndp" , NoArg (addNoDups v_Ways WayNDP) ) - , ( "threaded" , NoArg (addNoDups v_Ways WayThreaded) ) - -- ToDo: user ways - - ------ RTS ways ----------------------------------------------------- - - ------ Debugging ---------------------------------------------------- - , ( "dppr-noprags", PassFlag (add v_Opt_C) ) - , ( "dppr-debug", PassFlag (add v_Opt_C) ) - , ( "dppr-user-length", AnySuffix (add v_Opt_C) ) - -- rest of the debugging flags are dynamic - - --------- Profiling -------------------------------------------------- - , ( "auto-dicts" , NoArg (add v_Opt_C "-fauto-sccs-on-dicts") ) - , ( "auto-all" , NoArg (add v_Opt_C "-fauto-sccs-on-all-toplevs") ) - , ( "auto" , NoArg (add v_Opt_C "-fauto-sccs-on-exported-toplevs") ) - , ( "caf-all" , NoArg (add v_Opt_C "-fauto-sccs-on-individual-cafs") ) - -- "ignore-sccs" doesn't work (ToDo) - - , ( "no-auto-dicts" , NoArg (add v_Anti_opt_C "-fauto-sccs-on-dicts") ) - , ( "no-auto-all" , NoArg (add v_Anti_opt_C "-fauto-sccs-on-all-toplevs") ) - , ( "no-auto" , NoArg (add v_Anti_opt_C "-fauto-sccs-on-exported-toplevs") ) - , ( "no-caf-all" , NoArg (add v_Anti_opt_C "-fauto-sccs-on-individual-cafs") ) - - ------- Miscellaneous ----------------------------------------------- - , ( "no-link-chk" , NoArg (return ()) ) -- ignored for backwards compat - , ( "no-hs-main" , NoArg (writeIORef v_NoHsMain True) ) - , ( "main-is" , SepArg setMainIs ) - - ------- Output Redirection ------------------------------------------ - , ( "odir" , HasArg (writeIORef v_Output_dir . Just) ) - , ( "o" , SepArg (writeIORef v_Output_file . Just) ) - , ( "osuf" , HasArg (writeIORef v_Object_suf) ) - , ( "hcsuf" , HasArg (writeIORef v_HC_suf ) ) - , ( "hisuf" , HasArg (writeIORef v_Hi_suf ) ) - , ( "hidir" , HasArg (writeIORef v_Hi_dir . Just) ) - , ( "buildtag" , HasArg (writeIORef v_Build_tag) ) - , ( "tmpdir" , HasArg setTmpDir) - , ( "ohi" , HasArg (writeIORef v_Output_hi . Just) ) - -- -odump? - - , ( "keep-hc-file" , AnySuffix (\_ -> writeIORef v_Keep_hc_files True) ) - , ( "keep-s-file" , AnySuffix (\_ -> writeIORef v_Keep_s_files True) ) - , ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef v_Keep_raw_s_files True) ) -#ifdef ILX - , ( "keep-il-file" , AnySuffix (\_ -> writeIORef v_Keep_il_files True) ) - , ( "keep-ilx-file" , AnySuffix (\_ -> writeIORef v_Keep_ilx_files True) ) -#endif - , ( "keep-tmp-files" , AnySuffix (\_ -> writeIORef v_Keep_tmp_files True) ) - - , ( "split-objs" , NoArg (if can_split - then do writeIORef v_Split_object_files True - add v_Opt_C "-fglobalise-toplev-names" - else hPutStrLn stderr - "warning: don't know how to split object files on this architecture" - ) ) - - ------- Include/Import Paths ---------------------------------------- - , ( "I" , Prefix (addToDirList v_Include_paths) ) - - ------- Libraries --------------------------------------------------- - , ( "L" , Prefix (addToDirList v_Library_paths) ) - , ( "l" , AnySuffix (\s -> add v_Opt_l s >> add v_Opt_dll s) ) - -#ifdef darwin_TARGET_OS - ------- Frameworks -------------------------------------------------- - -- -framework-path should really be -F ... - , ( "framework-path" , HasArg (addToDirList v_Framework_paths) ) - , ( "framework" , HasArg (add v_Cmdline_frameworks) ) -#endif - ------- Specific phases -------------------------------------------- - , ( "pgmL" , HasArg setPgmL ) - , ( "pgmP" , HasArg setPgmP ) - , ( "pgmF" , HasArg setPgmF ) - , ( "pgmc" , HasArg setPgmc ) - , ( "pgmm" , HasArg setPgmm ) - , ( "pgms" , HasArg setPgms ) - , ( "pgma" , HasArg setPgma ) - , ( "pgml" , HasArg setPgml ) - , ( "pgmdll" , HasArg setPgmDLL ) -#ifdef ILX - , ( "pgmI" , HasArg setPgmI ) - , ( "pgmi" , HasArg setPgmi ) -#endif - - , ( "optdep" , HasArg (add v_Opt_dep) ) - , ( "optl" , HasArg (add v_Opt_l) ) - , ( "optdll" , HasArg (add v_Opt_dll) ) - - ----- Linker -------------------------------------------------------- - , ( "c" , NoArg (writeIORef v_GhcLink NoLink) ) - , ( "no-link" , NoArg (writeIORef v_GhcLink NoLink) ) -- Deprecated - , ( "static" , NoArg (writeIORef v_Static True) ) - , ( "dynamic" , NoArg (writeIORef v_Static False) ) - , ( "rdynamic" , NoArg (return ()) ) -- ignored for compat w/ gcc - - ----- RTS opts ------------------------------------------------------ - , ( "H" , HasArg (setHeapSize . fromIntegral . decodeSize) ) - , ( "Rghc-timing" , NoArg (enableTimingStats) ) - - ------ Compiler flags ----------------------------------------------- - , ( "fno-asm-mangling" , NoArg (writeIORef v_Do_asm_mangling False) ) - - , ( "fexcess-precision" , NoArg (do writeIORef v_Excess_precision True - add v_Opt_C "-fexcess-precision")) - - -- All other "-fno-" options cancel out "-f" on the hsc cmdline - , ( "fno-", PrefixPred (\s -> isStaticHscFlag ("f"++s)) - (\s -> add v_Anti_opt_C ("-f"++s)) ) - - -- Pass all remaining "-f" options to hsc - , ( "f", AnySuffixPred (isStaticHscFlag) (add v_Opt_C) ) - ] - -dynamic_flags = [ - - ( "cpp", NoArg (updDynFlags (\s -> s{ cppFlag = True })) ) - , ( "F", NoArg (updDynFlags (\s -> s{ ppFlag = True })) ) - , ( "#include", HasArg (addCmdlineHCInclude) ) - - , ( "v", OptPrefix (setVerbosity) ) - - , ( "optL", HasArg (addOpt_L) ) - , ( "optP", HasArg (addOpt_P) ) - , ( "optF", HasArg (addOpt_F) ) - , ( "optc", HasArg (addOpt_c) ) - , ( "optm", HasArg (addOpt_m) ) - , ( "opta", HasArg (addOpt_a) ) -#ifdef ILX - , ( "optI", HasArg (addOpt_I) ) - , ( "opti", HasArg (addOpt_i) ) -#endif - - ------- recompilation checker -------------------------------------- - , ( "recomp" , NoArg (setRecompFlag True) ) - , ( "no-recomp" , NoArg (setRecompFlag False) ) - - ------- Packages ---------------------------------------------------- - , ( "package-conf" , HasArg extraPkgConf_ ) - , ( "no-user-package-conf", NoArg noUserPkgConf_ ) - , ( "package-name" , HasArg ignorePackage ) -- for compatibility - , ( "package" , HasArg exposePackage ) - , ( "hide-package" , HasArg hidePackage ) - , ( "ignore-package" , HasArg ignorePackage ) - , ( "syslib" , HasArg exposePackage ) -- for compatibility - - ------ HsCpp opts --------------------------------------------------- - , ( "D", AnySuffix addOpt_P ) - , ( "U", AnySuffix addOpt_P ) - - ------- Paths & stuff ----------------------------------------------- - , ( "i" , OptPrefix addImportPath ) - - ------ Debugging ---------------------------------------------------- - , ( "dstg-stats", NoArg (writeIORef v_StgStats True) ) - - , ( "ddump-cmm", setDumpFlag Opt_D_dump_cmm) - , ( "ddump-asm", setDumpFlag Opt_D_dump_asm) - , ( "ddump-cpranal", setDumpFlag Opt_D_dump_cpranal) - , ( "ddump-deriv", setDumpFlag Opt_D_dump_deriv) - , ( "ddump-ds", setDumpFlag Opt_D_dump_ds) - , ( "ddump-flatC", setDumpFlag Opt_D_dump_flatC) - , ( "ddump-foreign", setDumpFlag Opt_D_dump_foreign) - , ( "ddump-inlinings", setDumpFlag Opt_D_dump_inlinings) - , ( "ddump-occur-anal", setDumpFlag Opt_D_dump_occur_anal) - , ( "ddump-parsed", setDumpFlag Opt_D_dump_parsed) - , ( "ddump-rn", setDumpFlag Opt_D_dump_rn) - , ( "ddump-simpl", setDumpFlag Opt_D_dump_simpl) - , ( "ddump-simpl-iterations", setDumpFlag Opt_D_dump_simpl_iterations) - , ( "ddump-spec", setDumpFlag Opt_D_dump_spec) - , ( "ddump-prep", setDumpFlag Opt_D_dump_prep) - , ( "ddump-stg", setDumpFlag Opt_D_dump_stg) - , ( "ddump-stranal", setDumpFlag Opt_D_dump_stranal) - , ( "ddump-tc", setDumpFlag Opt_D_dump_tc) - , ( "ddump-types", setDumpFlag Opt_D_dump_types) - , ( "ddump-rules", setDumpFlag Opt_D_dump_rules) - , ( "ddump-cse", setDumpFlag Opt_D_dump_cse) - , ( "ddump-worker-wrapper", setDumpFlag Opt_D_dump_worker_wrapper) - , ( "ddump-rn-trace", NoArg (setDynFlag Opt_D_dump_rn_trace)) - , ( "ddump-if-trace", NoArg (setDynFlag Opt_D_dump_if_trace)) - , ( "ddump-tc-trace", setDumpFlag Opt_D_dump_tc_trace) - , ( "ddump-splices", setDumpFlag Opt_D_dump_splices) - , ( "ddump-rn-stats", NoArg (setDynFlag Opt_D_dump_rn_stats)) - , ( "ddump-opt-cmm", setDumpFlag Opt_D_dump_opt_cmm) - , ( "ddump-simpl-stats", setDumpFlag Opt_D_dump_simpl_stats) - , ( "ddump-bcos", setDumpFlag Opt_D_dump_BCOs) - , ( "dsource-stats", setDumpFlag Opt_D_source_stats) - , ( "dverbose-core2core", setDumpFlag Opt_D_verbose_core2core) - , ( "dverbose-stg2stg", setDumpFlag Opt_D_verbose_stg2stg) - , ( "ddump-hi-diffs", setDumpFlag Opt_D_dump_hi_diffs) - , ( "ddump-hi", setDumpFlag Opt_D_dump_hi) - , ( "ddump-minimal-imports", setDumpFlag Opt_D_dump_minimal_imports) - , ( "ddump-vect", setDumpFlag Opt_D_dump_vect) - , ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting)) - , ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting)) - , ( "dcmm-lint", NoArg (setDynFlag Opt_DoCmmLinting)) - , ( "dshow-passes", NoArg (setRecompFlag False >> setVerbosity "2") ) - - ------ Machine dependant (-m) stuff --------------------------- - - , ( "monly-2-regs", NoArg (updDynFlags (\s -> s{stolen_x86_regs = 2}) )) - , ( "monly-3-regs", NoArg (updDynFlags (\s -> s{stolen_x86_regs = 3}) )) - , ( "monly-4-regs", NoArg (updDynFlags (\s -> s{stolen_x86_regs = 4}) )) - - ------ Warning opts ------------------------------------------------- - , ( "W" , NoArg (mapM_ setDynFlag minusWOpts) ) - , ( "Werror" , NoArg (setDynFlag Opt_WarnIsError) ) - , ( "Wall" , NoArg (mapM_ setDynFlag minusWallOpts) ) - , ( "Wnot" , NoArg (mapM_ unSetDynFlag minusWallOpts) ) /* DEPREC */ - , ( "w" , NoArg (mapM_ unSetDynFlag minusWallOpts) ) - - ------ Optimisation flags ------------------------------------------ - , ( "O" , NoArg (setOptLevel 1)) - , ( "Onot" , NoArg (setOptLevel 0)) - , ( "O" , PrefixPred (all isDigit) (setOptLevel . read)) - - , ( "fmax-simplifier-iterations", - PrefixPred (all isDigit) - (\n -> updDynFlags (\dfs -> - dfs{ maxSimplIterations = read n })) ) - - , ( "frule-check", - SepArg (\s -> updDynFlags (\dfs -> dfs{ ruleCheck = Just s }))) - - ------ Compiler flags ----------------------------------------------- - - , ( "fasm", AnySuffix (\_ -> setTarget HscAsm) ) - , ( "fvia-c", NoArg (setTarget HscC) ) - , ( "fvia-C", NoArg (setTarget HscC) ) - , ( "filx", NoArg (setTarget HscILX) ) - - , ( "fglasgow-exts", NoArg (mapM_ setDynFlag glasgowExtsFlags) ) - , ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) ) - - -- the rest of the -f* and -fno-* flags - , ( "fno-", PrefixPred (\f -> isFFlag f) (\f -> unSetDynFlag (getFFlag f)) ) - , ( "f", PrefixPred (\f -> isFFlag f) (\f -> setDynFlag (getFFlag f)) ) - ] - --- these -f flags can all be reversed with -fno- - -fFlags = [ - ( "warn-duplicate-exports", Opt_WarnDuplicateExports ), - ( "warn-hi-shadowing", Opt_WarnHiShadows ), - ( "warn-incomplete-patterns", Opt_WarnIncompletePatterns ), - ( "warn-incomplete-record-updates", Opt_WarnIncompletePatternsRecUpd ), - ( "warn-missing-fields", Opt_WarnMissingFields ), - ( "warn-missing-methods", Opt_WarnMissingMethods ), - ( "warn-missing-signatures", Opt_WarnMissingSigs ), - ( "warn-name-shadowing", Opt_WarnNameShadowing ), - ( "warn-overlapping-patterns", Opt_WarnOverlappingPatterns ), - ( "warn-simple-patterns", Opt_WarnSimplePatterns ), - ( "warn-type-defaults", Opt_WarnTypeDefaults ), - ( "warn-unused-binds", Opt_WarnUnusedBinds ), - ( "warn-unused-imports", Opt_WarnUnusedImports ), - ( "warn-unused-matches", Opt_WarnUnusedMatches ), - ( "warn-deprecations", Opt_WarnDeprecations ), - ( "warn-orphans", Opt_WarnOrphans ), - ( "fi", Opt_FFI ), -- support `-ffi'... - ( "ffi", Opt_FFI ), -- ...and also `-fffi' - ( "arrows", Opt_Arrows ), -- arrow syntax - ( "parr", Opt_PArr ), - ( "th", Opt_TH ), - ( "implicit-prelude", Opt_ImplicitPrelude ), - ( "scoped-type-variables", Opt_ScopedTypeVariables ), - ( "monomorphism-restriction", Opt_MonomorphismRestriction ), - ( "implicit-params", Opt_ImplicitParams ), - ( "allow-overlapping-instances", Opt_AllowOverlappingInstances ), - ( "allow-undecidable-instances", Opt_AllowUndecidableInstances ), - ( "allow-incoherent-instances", Opt_AllowIncoherentInstances ), - ( "generics", Opt_Generics ), - ( "strictness", Opt_Strictness ), - ( "full-laziness", Opt_FullLaziness ), - ( "cse", Opt_CSE ), - ( "ignore-interface-pragmas", Opt_IgnoreInterfacePragmas ), - ( "omit-interface-pragmas", Opt_OmitInterfacePragmas ), - ( "do-lambda-eta-expansion", Opt_DoLambdaEtaExpansion ), - ( "ignore-asserts", Opt_IgnoreAsserts ), - ( "do-eta-reduction", Opt_DoEtaReduction ), - ( "case-merge", Opt_CaseMerge ), - ( "unbox-strict-fields", Opt_UnboxStrictFields ) - ] - -glasgowExtsFlags = [ Opt_GlasgowExts, Opt_FFI, Opt_TH, Opt_ImplicitParams, Opt_ScopedTypeVariables ] - -isFFlag f = f `elem` (map fst fFlags) -getFFlag f = fromJust (lookup f fFlags) - --- ----------------------------------------------------------------------------- --- Parsing the dynamic flags. - --- we use a temporary global variable, for convenience - -GLOBAL_VAR(v_DynFlags, defaultDynFlags, DynFlags) - -processDynamicFlags :: [String] -> DynFlags -> IO (DynFlags,[String]) -processDynamicFlags args dflags = do - writeIORef v_DynFlags dflags - spare <- processArgs dynamic_flags args [] - dflags <- readIORef v_DynFlags - return (dflags,spare) - -updDynFlags :: (DynFlags -> DynFlags) -> IO () -updDynFlags f = do dfs <- readIORef v_DynFlags - writeIORef v_DynFlags (f dfs) - -setDynFlag, unSetDynFlag :: DynFlag -> IO () -setDynFlag f = updDynFlags (\dfs -> dopt_set dfs f) -unSetDynFlag f = updDynFlags (\dfs -> dopt_unset dfs f) - -setDumpFlag :: DynFlag -> OptKind -setDumpFlag dump_flag - = NoArg (setRecompFlag False >> setDynFlag dump_flag) - -- Whenver we -ddump, switch off the recompilation checker, - -- else you don't see the dump! - -addOpt_L a = updDynFlags (\s -> s{opt_L = a : opt_L s}) -addOpt_P a = updDynFlags (\s -> s{opt_P = a : opt_P s}) -addOpt_F a = updDynFlags (\s -> s{opt_F = a : opt_F s}) -addOpt_c a = updDynFlags (\s -> s{opt_c = a : opt_c s}) -addOpt_a a = updDynFlags (\s -> s{opt_a = a : opt_a s}) -addOpt_m a = updDynFlags (\s -> s{opt_m = a : opt_m s}) -#ifdef ILX -addOpt_I a = updDynFlags (\s -> s{opt_I = a : opt_I s}) -addOpt_i a = updDynFlags (\s -> s{opt_i = a : opt_i s}) -#endif - -setRecompFlag :: Bool -> IO () -setRecompFlag recomp = updDynFlags (\dfs -> dfs{ recompFlag = recomp }) - -setVerbosity "" = updDynFlags (\dfs -> dfs{ verbosity = 3 }) -setVerbosity n - | all isDigit n = updDynFlags (\dfs -> dfs{ verbosity = read n }) - | otherwise = throwDyn (UsageError "can't parse verbosity flag (-v)") - -addCmdlineHCInclude a = updDynFlags (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s}) - -extraPkgConf_ p = updDynFlags (\s -> s{ extraPkgConfs = p : extraPkgConfs s }) -noUserPkgConf_ = updDynFlags (\s -> s{ readUserPkgConf = False }) - -exposePackage p = - updDynFlags (\s -> s{ packageFlags = ExposePackage p : packageFlags s }) -hidePackage p = - updDynFlags (\s -> s{ packageFlags = HidePackage p : packageFlags s }) -ignorePackage p = - updDynFlags (\s -> s{ packageFlags = IgnorePackage p : packageFlags s }) - --- -i on its own deletes the import paths -addImportPath "" = updDynFlags (\s -> s{importPaths = []}) -addImportPath p = do - paths <- splitPathList p - updDynFlags (\s -> s{importPaths = importPaths s ++ paths}) - --- we can only switch between HscC, HscAsmm, and HscILX with dynamic flags --- (-fvia-C, -fasm, -filx respectively). -setTarget l = updDynFlags (\dfs -> case hscTarget dfs of - HscC -> dfs{ hscTarget = l } - HscAsm -> dfs{ hscTarget = l } - HscILX -> dfs{ hscTarget = l } - _ -> dfs) - -setOptLevel :: Int -> IO () -setOptLevel n - = do dflags <- readIORef v_DynFlags - if hscTarget dflags == HscInterpreted && n > 0 - then putStr "warning: -O conflicts with --interactive; -O ignored.\n" - else writeIORef v_DynFlags (updOptLevel n dflags) - ------------------------------------------------------------------------------ --- convert sizes like "3.5M" into integers - -decodeSize :: String -> Integer -decodeSize str - | c == "" = truncate n - | c == "K" || c == "k" = truncate (n * 1000) - | c == "M" || c == "m" = truncate (n * 1000 * 1000) - | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000) - | otherwise = throwDyn (CmdLineError ("can't decode size: " ++ str)) - where (m, c) = span pred str - n = read m :: Double - pred c = isDigit c || c == '.' - - ------------------------------------------------------------------------------ --- RTS Hooks - -#if __GLASGOW_HASKELL__ >= 504 -foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO () -foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO () -#else -foreign import "setHeapSize" unsafe setHeapSize :: Int -> IO () -foreign import "enableTimingStats" unsafe enableTimingStats :: IO () -#endif - ------------------------------------------------------------------------------ --- Build the Hsc static command line opts - -buildStaticHscOpts :: IO [String] -buildStaticHscOpts = do - - opt_C_ <- getStaticOpts v_Opt_C -- misc hsc opts from the command line - - -- take into account -fno-* flags by removing the equivalent -f* - -- flag from our list. - anti_flags <- getStaticOpts v_Anti_opt_C - let basic_opts = opt_C_ - filtered_opts = filter (`notElem` anti_flags) basic_opts - - static <- (do s <- readIORef v_Static; if s then return "-static" - else return "") - - return ( static : filtered_opts ) - -setMainIs :: String -> IO () -setMainIs arg - | not (null main_mod) -- The arg looked like "Foo.baz" - = do { writeIORef v_MainFunIs (Just main_fn) ; - writeIORef v_MainModIs (Just main_mod) } - - | isUpper (head main_fn) -- The arg looked like "Foo" - = writeIORef v_MainModIs (Just main_fn) - - | otherwise -- The arg looked like "baz" - = writeIORef v_MainFunIs (Just main_fn) - where - (main_mod, main_fn) = split_longest_prefix arg (== '.') - - ------------------------------------------------------------------------------ --- Via-C compilation stuff - --- flags returned are: ( all C compilations --- , registerised HC compilations --- ) - -machdepCCOpts dflags -#if alpha_TARGET_ARCH - = return ( ["-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.) - = return ( ["-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].) - = return ( [], ["-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. - = do let n_regs = stolen_x86_regs dflags - sta <- readIORef v_Static - return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" --- , if suffixMatch "mingw32" cTARGETPLATFORM then "-mno-cygwin" else "" - ], - [ "-fno-defer-pop", -#ifdef HAVE_GCC_MNO_OMIT_LFPTR - -- Some gccs are configured with - -- -momit-leaf-frame-pointer on by default, and it - -- apparently takes precedence over - -- -fomit-frame-pointer, so we disable it first here. - "-mno-omit-leaf-frame-pointer", -#endif - "-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 - = return ( [], ["-fomit-frame-pointer", "-G0"] ) - -#elif x86_64_TARGET_ARCH - = return ( [], ["-fomit-frame-pointer"] ) - -#elif mips_TARGET_ARCH - = return ( ["-static"], [] ) - -#elif sparc_TARGET_ARCH - = return ( [], ["-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. - = return ( [], ["-no-cpp-precomp"] ) -#else - = return ( [], [] ) -#endif - -picCCOpts dflags -#if darwin_TARGET_OS - -- Apple prefers to do things the other way round. - -- PIC is on by default. - -- -mdynamic-no-pic: - -- Turn off PIC code generation. - -- -fno-common: - -- Don't generate "common" symbols - these are unwanted - -- in dynamic libraries. - - | opt_PIC - = return ["-fno-common"] - | otherwise - = return ["-mdynamic-no-pic"] -#elif mingw32_TARGET_OS - -- no -fPIC for Windows - = return [] -#else - | opt_PIC - = return ["-fPIC"] - | otherwise - = return [] -#endif - ------------------------------------------------------------------------------ --- local utils - --- ----------------------------------------------------------------------------- --- Version and usage messages - -showVersion :: IO () -showVersion = do - putStrLn (cProjectName ++ ", version " ++ cProjectVersion) - exitWith ExitSuccess - -showGhcUsage = do - (ghc_usage_path,ghci_usage_path) <- getUsageMsgPaths - mode <- readIORef v_GhcMode - let usage_path - | DoInteractive <- mode = ghci_usage_path - | otherwise = ghc_usage_path - usage <- readFile usage_path - dump usage - exitWith ExitSuccess - where - dump "" = return () - dump ('$':'$':s) = hPutStr stderr progName >> dump s - dump (c:s) = hPutChar stderr c >> dump s diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs index a4c0233..3837d2c 100644 --- a/ghc/compiler/main/DriverMkDepend.hs +++ b/ghc/compiler/main/DriverMkDepend.hs @@ -1,9 +1,8 @@ ----------------------------------------------------------------------------- --- $Id: DriverMkDepend.hs,v 1.42 2005/02/22 16:29:42 simonpj Exp $ -- --- GHC Driver +-- Makefile Dependency Generation -- --- (c) Simon Marlow 2000 +-- (c) The University of Glasgow 2005 -- ----------------------------------------------------------------------------- @@ -14,20 +13,21 @@ module DriverMkDepend ( #include "HsVersions.h" import CompManager ( cmDownsweep, cmTopSort, cyclicModuleErr ) -import CmdLineOpts ( DynFlags( verbosity ) ) -import DriverState ( getStaticOpts, v_Opt_dep ) -import DriverUtil ( escapeSpaces, splitFilename, add ) -import DriverFlags ( processArgs, OptKind(..) ) -import HscTypes ( IsBootInterface, ModSummary(..), msObjFilePath, msHsFilePath ) +import DynFlags ( DynFlags( verbosity, opt_dep ), getOpts ) +import Util ( escapeSpaces, splitFilename ) +import HscTypes ( IsBootInterface, ModSummary(..), msObjFilePath, + msHsFilePath ) import Packages ( PackageIdH(..) ) import SysTools ( newTempName ) import qualified SysTools -import Module ( Module, ModLocation(..), mkModule, moduleUserString, addBootSuffix_maybe ) +import Module ( Module, ModLocation(..), mkModule, moduleUserString, + addBootSuffix_maybe ) import Digraph ( SCC(..) ) import Finder ( findModule, FindResult(..) ) -import Util ( global ) +import Util ( global, consIORef ) import Outputable import Panic +import CmdLineParser import DATA_IOREF ( IORef, readIORef, writeIORef ) import EXCEPTION @@ -50,7 +50,7 @@ import Panic ( catchJust, ioErrors ) doMkDependHS :: DynFlags -> [FilePath] -> IO () doMkDependHS dflags srcs = do { -- Initialisation - files <- beginMkDependHS + files <- beginMkDependHS dflags -- Do the downsweep to find all the modules ; excl_mods <- readIORef v_Dep_exclude_mods @@ -87,12 +87,12 @@ data MkDepFiles mkd_tmp_file :: FilePath, -- Name of the temporary file mkd_tmp_hdl :: Handle } -- Handle of the open temporary file -beginMkDependHS :: IO MkDepFiles +beginMkDependHS :: DynFlags -> IO MkDepFiles -beginMkDependHS = do +beginMkDependHS dflags = do -- slurp in the mkdependHS-style options - flags <- getStaticOpts v_Opt_dep - _ <- processArgs dep_opts flags [] + let flags = getOpts dflags opt_dep + _ <- processArgs dep_opts flags -- open a new temp file in which to stuff the dependency info -- as we go along. @@ -319,11 +319,11 @@ depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" -- for compatibility with the old mkDependHS, we accept options of the form -- -optdep-f -optdep.depend, etc. dep_opts = - [ ( "s", SepArg (add v_Dep_suffixes) ) + [ ( "s", SepArg (consIORef v_Dep_suffixes) ) , ( "f", SepArg (writeIORef v_Dep_makefile) ) , ( "w", NoArg (writeIORef v_Dep_warnings False) ) , ( "-include-prelude", NoArg (writeIORef v_Dep_include_pkg_deps True) ) , ( "-include-pkg-deps", NoArg (writeIORef v_Dep_include_pkg_deps True) ) - , ( "-exclude-module=", Prefix (add v_Dep_exclude_mods . mkModule) ) - , ( "x", Prefix (add v_Dep_exclude_mods . mkModule) ) + , ( "-exclude-module=", Prefix (consIORef v_Dep_exclude_mods . mkModule) ) + , ( "x", Prefix (consIORef v_Dep_exclude_mods . mkModule) ) ] diff --git a/ghc/compiler/main/DriverPhases.hs b/ghc/compiler/main/DriverPhases.hs index a1c3309..693c4e1 100644 --- a/ghc/compiler/main/DriverPhases.hs +++ b/ghc/compiler/main/DriverPhases.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPhases.hs,v 1.34 2005/01/31 16:59:37 simonpj Exp $ +-- $Id: DriverPhases.hs,v 1.35 2005/03/18 13:39:05 simonmar Exp $ -- -- GHC Driver -- @@ -9,7 +9,7 @@ module DriverPhases ( HscSource(..), isHsBoot, hscSourceString, - HscTarget(..), Phase(..), + Phase(..), happensBefore, eqPhase, anyHsc, isStopLn, startPhase, -- :: String -> Phase phaseInputExt, -- :: Phase -> String @@ -24,7 +24,7 @@ module DriverPhases ( isSourceFilename -- :: FilePath -> Bool ) where -import DriverUtil +import Util ( getFileSuffix ) import Panic ( panic ) ----------------------------------------------------------------------------- @@ -57,15 +57,6 @@ isHsBoot :: HscSource -> Bool isHsBoot HsBootFile = True isHsBoot other = False -data HscTarget - = HscC - | HscAsm - | HscJava - | HscILX - | HscInterpreted - | HscNothing - deriving (Eq, Show) - data Phase = Unlit HscSource | Cpp HscSource @@ -79,15 +70,10 @@ data Phase | As | CmmCpp -- pre-process Cmm source | Cmm -- parse & compile Cmm code -#ifdef ILX - | Ilx2Il - | Ilasm -#endif -- The final phase is a pseudo-phase that tells the pipeline to stop. -- There is no runPhase case for it. | StopLn -- Stop, but linking will follow, so generate .o file - deriving (Show) anyHsc :: Phase diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 1856dce..9ffc9db 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -7,9 +7,11 @@ ----------------------------------------------------------------------------- module DriverPipeline ( + -- Run a series of compilation steps in a pipeline + runPipeline, -- Interfaces for the batch-mode driver - compileFile, staticLink, + staticLink, -- Interfaces for the compilation manager (interpreted/batch-mode) preprocess, @@ -24,10 +26,7 @@ module DriverPipeline ( import Packages import GetImports -import DriverState -import DriverUtil import DriverPhases -import DriverFlags import SysTools ( newTempName, addFilesToClean, getSysMan, copy ) import qualified SysTools import HscMain @@ -36,7 +35,8 @@ import HscTypes import Outputable import Module import ErrUtils -import CmdLineOpts +import DynFlags +import StaticFlags ( v_Ld_inputs, opt_Static, WayName(..) ) import Config import RdrName ( GlobalRdrEnv ) import Panic @@ -44,11 +44,12 @@ import Util import StringBuffer ( hGetStringBuffer ) import BasicTypes ( SuccessFlag(..) ) import Maybes ( expectJust ) +import Ctype ( is_ident ) import ParserCoreUtils ( getCoreModuleName ) import EXCEPTION -import DATA_IOREF ( readIORef, writeIORef ) +import DATA_IOREF ( readIORef, writeIORef, IORef ) import Directory import System @@ -69,7 +70,7 @@ import Maybe preprocess :: DynFlags -> FilePath -> IO (DynFlags, FilePath) preprocess dflags filename = ASSERT2(isHaskellSrcFilename filename, text filename) - runPipeline anyHsc "preprocess" dflags + runPipeline anyHsc dflags False{-temporary output file-} Nothing{-no specific output file-} filename @@ -78,37 +79,6 @@ preprocess dflags filename = -- --------------------------------------------------------------------------- --- Compile a file --- This is used in batch mode -compileFile :: GhcMode -> DynFlags -> FilePath -> IO FilePath -compileFile mode dflags src = do - exists <- doesFileExist src - when (not exists) $ - throwDyn (CmdLineError ("file `" ++ src ++ "' does not exist")) - - split <- readIORef v_Split_object_files - o_file <- readIORef v_Output_file - ghc_link <- readIORef v_GhcLink -- Set by -c or -no-link - -- When linking, the -o argument refers to the linker's output. - -- otherwise, we use it as the name for the pipeline's output. - let maybe_o_file - | isLinkMode mode && not (isNoLink ghc_link) = Nothing - -- -o foo applies to linker - | otherwise = o_file - -- -o foo applies to the file we are compiling now - - stop_phase = case mode of - StopBefore As | split -> SplitAs - StopBefore phase -> phase - other -> StopLn - - mode_flag_string <- readIORef v_GhcModeFlag - (_, out_file) <- runPipeline stop_phase mode_flag_string dflags - True maybe_o_file src Nothing{-no ModLocation-} - return out_file - - --- --------------------------------------------------------------------------- -- Compile -- Compile a single module, under the control of the compilation manager. @@ -145,13 +115,13 @@ data CompResult compile hsc_env mod_summary source_unchanged have_object old_iface = do - let dyn_flags = hsc_dflags hsc_env + let dflags0 = hsc_dflags hsc_env this_mod = ms_mod mod_summary src_flavour = ms_hsc_src mod_summary - showPass dyn_flags ("Compiling " ++ showModMsg have_object mod_summary) + showPass dflags0 ("Compiling " ++ showModMsg have_object mod_summary) - let verb = verbosity dyn_flags + let verb = verbosity dflags0 let location = ms_location mod_summary let input_fn = expectJust "compile:hs" (ml_hs_file location) let input_fnpp = expectJust "compile:hspp" (ms_hspp_file mod_summary) @@ -162,7 +132,7 @@ compile hsc_env mod_summary -- This is nasty: we've done this once already, in the compilation manager -- It might be better to cache the flags in the ml_hspp_file field,say opts <- getOptionsFromSource input_fnpp - (dyn_flags,unhandled_flags) <- processDynamicFlags opts dyn_flags + (dflags1,unhandled_flags) <- parseDynamicFlags dflags0 opts checkProcessArgsResult unhandled_flags input_fn let (basename, _) = splitFilename input_fn @@ -171,29 +141,28 @@ compile hsc_env mod_summary -- This is needed when we try to compile the .hc file later, if it -- imports a _stub.h file that we created here. let current_dir = directoryOf basename - old_paths <- readIORef v_Include_paths - writeIORef v_Include_paths (current_dir : old_paths) - -- put back the old include paths afterward. - later (writeIORef v_Include_paths old_paths) $ do + old_paths = includePaths dflags1 + dflags = dflags1 { includePaths = current_dir : old_paths } -- Figure out what lang we're generating - hsc_lang <- hscMaybeAdjustTarget StopLn src_flavour (hscTarget dyn_flags) + let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags) -- ... and what the next phase should be - next_phase <- hscNextPhase src_flavour hsc_lang + let next_phase = hscNextPhase dflags src_flavour hsc_lang -- ... and what file to generate the output into - get_output_fn <- genOutputFilenameFunc next_phase False Nothing basename + let get_output_fn = genOutputFilenameFunc dflags next_phase + False Nothing basename output_fn <- get_output_fn next_phase (Just location) - let dyn_flags' = dyn_flags { hscTarget = hsc_lang, + let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, hscStubCOutName = basename ++ "_stub.c", hscStubHOutName = basename ++ "_stub.h", extCoreName = basename ++ ".hcr" } -- -no-recomp should also work with --make - let do_recomp = recompFlag dyn_flags + let do_recomp = dopt Opt_RecompChecking dflags source_unchanged' = source_unchanged && do_recomp - hsc_env' = hsc_env { hsc_dflags = dyn_flags' } + hsc_env' = hsc_env { hsc_dflags = dflags' } -- run the compiler hsc_result <- hscMain hsc_env' printErrorsAndWarnings mod_summary @@ -213,7 +182,7 @@ compile hsc_env mod_summary | otherwise -- Normal Haskell source files -> do let - maybe_stub_o <- compileStub dyn_flags' stub_c_exists + maybe_stub_o <- compileStub dflags' stub_c_exists let stub_unlinked = case maybe_stub_o of Nothing -> [] Just stub_o -> [ DotO stub_o ] @@ -240,7 +209,7 @@ compile hsc_env mod_summary _other -> do let object_filename = ml_obj_file location - runPipeline StopLn "" dyn_flags + runPipeline StopLn dflags True Nothing output_fn (Just location) -- the object filename comes from the ModLocation @@ -260,7 +229,7 @@ compileStub dflags stub_c_exists | stub_c_exists = do -- compile the _stub.c file w/ gcc let stub_c = hscStubCOutName dflags - (_, stub_o) <- runPipeline StopLn "stub-compile" dflags + (_, stub_o) <- runPipeline StopLn dflags True{-persistent output-} Nothing{-no specific output file-} stub_c @@ -271,7 +240,7 @@ compileStub dflags stub_c_exists -- --------------------------------------------------------------------------- -- Link -link :: GhciMode -- interactive or batch +link :: GhcMode -- interactive or batch -> DynFlags -- dynamic flags -> Bool -- attempt linking in batch mode? -> HomePackageTable -- what to link @@ -290,7 +259,7 @@ link Interactive dflags batch_attempt_linking hpt return Succeeded #endif -link Batch dflags batch_attempt_linking hpt +link BatchCompile dflags batch_attempt_linking hpt | batch_attempt_linking = do let @@ -307,8 +276,7 @@ link Batch dflags batch_attempt_linking hpt hPutStrLn stderr (showSDoc (vcat (map ppr linkables))) -- check for the -no-link flag - ghc_link <- readIORef v_GhcLink - if isNoLink ghc_link + if isNoLink (ghcLink dflags) then do when (verb >= 3) $ hPutStrLn stderr "link(batch): linking omitted (-c flag given)." return Succeeded @@ -345,7 +313,6 @@ link Batch dflags batch_attempt_linking hpt runPipeline :: Phase -- When to stop - -> String -- "GhcMode" flag as a string -> DynFlags -- Dynamic flags -> Bool -- Final output is persistent? -> Maybe FilePath -- Where to put the output, optionally @@ -353,7 +320,7 @@ runPipeline -> Maybe ModLocation -- A ModLocation for this module, if we have one -> IO (DynFlags, FilePath) -- (final flags, output filename) -runPipeline stop_phase mode_flag_string dflags keep_output +runPipeline stop_phase dflags keep_output maybe_output_filename input_fn maybe_loc = do let (basename, suffix) = splitFilename input_fn @@ -368,13 +335,12 @@ runPipeline stop_phase mode_flag_string dflags keep_output when (not (start_phase `happensBefore` stop_phase)) $ throwDyn (UsageError - ("flag `" ++ mode_flag_string - ++ "' is incompatible with source file `" - ++ input_fn ++ "'")) + ("cannot compile this file to desired target: " + ++ input_fn)) -- generate a function which will be used to calculate output file names -- as we go along. - get_output_fn <- genOutputFilenameFunc stop_phase keep_output + let get_output_fn = genOutputFilenameFunc dflags stop_phase keep_output maybe_output_filename basename -- Execute the pipeline... @@ -423,21 +389,19 @@ pipeLoop dflags phase stop_phase ; pipeLoop dflags' next_phase stop_phase output_fn orig_basename orig_suff orig_get_output_fn maybe_loc } -genOutputFilenameFunc :: Phase -> Bool -> Maybe FilePath -> String - -> IO (Phase{-next phase-} -> Maybe ModLocation -> IO FilePath) -genOutputFilenameFunc stop_phase keep_final_output maybe_output_filename basename - = do - hcsuf <- readIORef v_HC_suf - odir <- readIORef v_Output_dir - osuf <- readIORef v_Object_suf - keep_hc <- readIORef v_Keep_hc_files -#ifdef ILX - keep_il <- readIORef v_Keep_il_files - keep_ilx <- readIORef v_Keep_ilx_files -#endif - keep_raw_s <- readIORef v_Keep_raw_s_files - keep_s <- readIORef v_Keep_s_files - let +genOutputFilenameFunc :: DynFlags -> Phase -> Bool -> Maybe FilePath -> String + -> (Phase{-next phase-} -> Maybe ModLocation -> IO FilePath) +genOutputFilenameFunc dflags stop_phase keep_final_output + maybe_output_filename basename + = func + where + hcsuf = hcSuf dflags + odir = outputDir dflags + osuf = objectSuf dflags + keep_hc = dopt Opt_KeepHcFiles dflags + keep_raw_s = dopt Opt_KeepRawSFiles dflags + keep_s = dopt Opt_KeepSFiles dflags + myPhaseInputExt HCc = hcsuf myPhaseInputExt StopLn = osuf myPhaseInputExt other = phaseInputExt other @@ -474,8 +438,6 @@ genOutputFilenameFunc stop_phase keep_final_output maybe_output_filename basenam | Just d <- odir = replaceFilenameDirectory persistent d | otherwise = persistent - return func - -- ----------------------------------------------------------------------------- -- Each phase in the pipeline returns the next phase to execute, and the @@ -527,12 +489,12 @@ runPhase (Unlit sf) _stop dflags _basename _suff input_fn get_output_fn maybe_lo -- Cpp phase : (a) gets OPTIONS out of file -- (b) runs cpp if necessary -runPhase (Cpp sf) _stop dflags basename suff input_fn get_output_fn maybe_loc +runPhase (Cpp sf) _stop dflags0 basename suff input_fn get_output_fn maybe_loc = do src_opts <- getOptionsFromSource input_fn - (dflags,unhandled_flags) <- processDynamicFlags src_opts dflags + (dflags,unhandled_flags) <- parseDynamicFlags dflags0 src_opts checkProcessArgsResult unhandled_flags (basename++'.':suff) - if not (cppFlag dflags) then + if not (dopt Opt_Cpp dflags) then -- no need to preprocess CPP, just pass input file along -- to the next phase of the pipeline. return (HsPp sf, dflags, maybe_loc, input_fn) @@ -545,13 +507,12 @@ runPhase (Cpp sf) _stop dflags basename suff input_fn get_output_fn maybe_loc -- HsPp phase runPhase (HsPp sf) _stop dflags basename suff input_fn get_output_fn maybe_loc - = do if not (ppFlag dflags) then + = do if not (dopt Opt_Pp dflags) then -- no need to preprocess, just pass input file along -- to the next phase of the pipeline. return (Hsc sf, dflags, maybe_loc, input_fn) else do let hspp_opts = getOpts dflags opt_F - hs_src_pp_opts <- readIORef v_Hs_source_pp_opts let orig_fn = basename ++ '.':suff output_fn <- get_output_fn (Hsc sf) maybe_loc SysTools.runPp dflags @@ -559,7 +520,6 @@ runPhase (HsPp sf) _stop dflags basename suff input_fn get_output_fn maybe_loc , SysTools.Option input_fn , SysTools.FileOption "" output_fn ] ++ - map SysTools.Option hs_src_pp_opts ++ map SysTools.Option hspp_opts ) return (Hsc sf, dflags, maybe_loc, output_fn) @@ -569,7 +529,7 @@ runPhase (HsPp sf) _stop dflags basename suff input_fn get_output_fn maybe_loc -- Compilation of a single module, in "legacy" mode (_not_ under -- the direction of the compilation manager). -runPhase (Hsc src_flavour) stop dflags basename suff input_fn get_output_fn _maybe_loc +runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _maybe_loc = do -- normal Hsc mode, not mkdependHS -- we add the current directory (i.e. the directory in which @@ -577,8 +537,8 @@ runPhase (Hsc src_flavour) stop dflags basename suff input_fn get_output_fn _may -- what gcc does, and it's probably what you want. let current_dir = directoryOf basename - paths <- readIORef v_Include_paths - writeIORef v_Include_paths (current_dir : paths) + paths = includePaths dflags0 + dflags = dflags0 { includePaths = current_dir : paths } -- gather the imports and module name (hspp_buf,mod_name) <- @@ -597,7 +557,7 @@ runPhase (Hsc src_flavour) stop dflags basename suff input_fn get_output_fn _may -- the .hi and .o filenames, and this is as good a way -- as any to generate them, and better than most. (e.g. takes -- into accout the -osuf flags) - location1 <- mkHomeModLocation2 mod_name basename suff + location1 <- mkHomeModLocation2 dflags mod_name basename suff -- Boot-ify it if necessary let location2 | isHsBoot src_flavour = addBootSuffixLocn location1 @@ -607,8 +567,8 @@ runPhase (Hsc src_flavour) stop dflags basename suff input_fn get_output_fn _may -- Take -ohi into account if present -- This can't be done in mkHomeModuleLocation because -- it only applies to the module being compiles - ohi <- readIORef v_Output_hi - let location3 | Just fn <- ohi = location2{ ml_hi_file = fn } + let ohi = outputHi dflags + location3 | Just fn <- ohi = location2{ ml_hi_file = fn } | otherwise = location2 -- Take -o into account if present @@ -616,10 +576,9 @@ runPhase (Hsc src_flavour) stop dflags basename suff input_fn get_output_fn _may -- (If we're linking then the -o applies to the linked thing, not to -- the object file for one module.) -- Note the nasty duplication with the same computation in compileFile above - expl_o_file <- readIORef v_Output_file - ghc_link <- readIORef v_GhcLink - let location4 | Just ofile <- expl_o_file - , isNoLink ghc_link + let expl_o_file = outputFile dflags + location4 | Just ofile <- expl_o_file + , isNoLink (ghcLink dflags) = location3 { ml_obj_file = ofile } | otherwise = location3 @@ -650,7 +609,7 @@ runPhase (Hsc src_flavour) stop dflags basename suff input_fn get_output_fn _may -- changed (which the compiler itself figures out). -- Setting source_unchanged to False tells the compiler that M.o is out of -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. - let do_recomp = recompFlag dflags + let do_recomp = dopt Opt_RecompChecking dflags source_unchanged <- if not do_recomp || not (isStopLn stop) -- Set source_unchanged to False unconditionally if @@ -667,8 +626,8 @@ runPhase (Hsc src_flavour) stop dflags basename suff input_fn get_output_fn _may else return False -- get the DynFlags - hsc_lang <- hscMaybeAdjustTarget stop src_flavour (hscTarget dflags) - next_phase <- hscNextPhase src_flavour hsc_lang + let hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags) + let next_phase = hscNextPhase dflags src_flavour hsc_lang output_fn <- get_output_fn next_phase (Just location4) let dflags' = dflags { hscTarget = hsc_lang, @@ -677,7 +636,7 @@ runPhase (Hsc src_flavour) stop dflags basename suff input_fn get_output_fn _may hscStubHOutName = basename ++ "_stub.h", extCoreName = basename ++ ".hcr" } - hsc_env <- newHscEnv OneShot dflags' + hsc_env <- newHscEnv dflags' -- run the compiler! result <- hscMain hsc_env printErrorsAndWarnings @@ -701,7 +660,7 @@ runPhase (Hsc src_flavour) stop dflags basename suff input_fn get_output_fn _may maybe_stub_o <- compileStub dflags' stub_c_exists case maybe_stub_o of Nothing -> return () - Just stub_o -> add v_Ld_inputs stub_o + Just stub_o -> consIORef v_Ld_inputs stub_o -- In the case of hs-boot files, generate a dummy .o-boot -- stamp file for the benefit of Make @@ -722,8 +681,8 @@ runPhase CmmCpp stop dflags basename suff input_fn get_output_fn maybe_loc runPhase Cmm stop dflags basename suff input_fn get_output_fn maybe_loc = do - hsc_lang <- hscMaybeAdjustTarget stop HsSrcFile (hscTarget dflags) - next_phase <- hscNextPhase HsSrcFile hsc_lang + let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags) + let next_phase = hscNextPhase dflags HsSrcFile hsc_lang output_fn <- get_output_fn next_phase maybe_loc let dflags' = dflags { hscTarget = hsc_lang, @@ -749,7 +708,7 @@ runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc = do let cc_opts = getOpts dflags opt_c hcc = cc_phase `eqPhase` HCc - cmdline_include_paths <- readIORef v_Include_paths + let cmdline_include_paths = includePaths dflags -- HC files have the dependent packages stamped into them pkgs <- if hcc then getHCFilePackages input_fn else return [] @@ -761,22 +720,23 @@ runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc let include_paths = foldr (\ x xs -> "-I" : x : xs) [] (cmdline_include_paths ++ pkg_include_dirs) - (md_c_flags, md_regd_c_flags) <- machdepCCOpts dflags - pic_c_flags <- picCCOpts dflags + let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags + let pic_c_flags = picCCOpts dflags let verb = getVerbFlag dflags pkg_extra_cc_opts <- getPackageExtraCcOpts dflags pkgs - split_objs <- readIORef v_Split_object_files - let split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ] + let split_objs = dopt Opt_SplitObjs dflags + split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ] | otherwise = [ ] - excessPrecision <- readIORef v_Excess_precision + let excessPrecision = dopt Opt_ExcessPrecision dflags -- Decide next phase - mangle <- readIORef v_Do_asm_mangling - let next_phase + + let mangle = dopt Opt_DoAsmMangling dflags + next_phase | hcc && mangle = Mangle | otherwise = As output_fn <- get_output_fn next_phase maybe_loc @@ -822,8 +782,8 @@ runPhase Mangle stop dflags _basename _suff input_fn get_output_fn maybe_loc machdep_opts <- return [] #endif - split <- readIORef v_Split_object_files - let next_phase + let split = dopt Opt_SplitObjs dflags + next_phase | split = SplitMangle | otherwise = As output_fn <- get_output_fn next_phase maybe_loc @@ -868,7 +828,7 @@ runPhase SplitMangle stop dflags _basename _suff input_fn get_output_fn maybe_lo runPhase As stop dflags _basename _suff input_fn get_output_fn maybe_loc = do let as_opts = getOpts dflags opt_a - cmdline_include_paths <- readIORef v_Include_paths + let cmdline_include_paths = includePaths dflags output_fn <- get_output_fn StopLn maybe_loc @@ -893,17 +853,17 @@ runPhase SplitAs stop dflags basename _suff _input_fn get_output_fn maybe_loc (split_s_prefix, n) <- readIORef v_Split_info - odir <- readIORef v_Output_dir - let real_odir = case odir of - Nothing -> basename ++ "_split" - Just d -> d + let real_odir + | Just d <- outputDir dflags = d + | otherwise = basename ++ "_split" let assemble_file n = do let input_s = split_s_prefix ++ "__" ++ show n ++ ".s" let output_o = replaceFilenameDirectory (basename ++ "__" ++ show n ++ ".o") real_odir - real_o <- osuf_ify output_o + let osuf = objectSuf dflags + let real_o = replaceFilenameSuffix output_o osuf SysTools.runAs dflags (map SysTools.Option as_opts ++ [ SysTools.Option "-c" @@ -917,36 +877,6 @@ runPhase SplitAs stop dflags basename _suff _input_fn get_output_fn maybe_loc output_fn <- get_output_fn StopLn maybe_loc return (StopLn, dflags, maybe_loc, output_fn) -#ifdef ILX ------------------------------------------------------------------------------ --- Ilx2Il phase --- Run ilx2il over the ILX output, getting an IL file - -runPhase Ilx2Il stop dflags _basename _suff input_fn get_output_fn maybe_loc - = do let ilx2il_opts = getOpts dflags opt_I - SysTools.runIlx2il (map SysTools.Option ilx2il_opts - ++ [ SysTools.Option "--no-add-suffix-to-assembly", - SysTools.Option "mscorlib", - SysTools.Option "-o", - SysTools.FileOption "" output_fn, - SysTools.FileOption "" input_fn ]) - return True - ------------------------------------------------------------------------------ --- Ilasm phase --- Run ilasm over the IL, getting a DLL - -runPhase Ilasm stop dflags _basename _suff input_fn get_output_fn maybe_loc - = do let ilasm_opts = getOpts dflags opt_i - SysTools.runIlasm (map SysTools.Option ilasm_opts - ++ [ SysTools.Option "/QUIET", - SysTools.Option "/DLL", - SysTools.FileOption "/OUT=" output_fn, - SysTools.FileOption "" input_fn ]) - return True - -#endif /* ILX */ - ----------------------------------------------------------------------------- -- MoveBinary sort-of-phase -- After having produced a binary, move it somewhere else and generate a @@ -1070,14 +1000,12 @@ getHCFilePackages filename = staticLink :: DynFlags -> [FilePath] -> [PackageId] -> IO () staticLink dflags o_files dep_packages = do let verb = getVerbFlag dflags - static <- readIORef v_Static - no_hs_main <- readIORef v_NoHsMain -- get the full list of packages to link with, by combining the -- explicit packages with the auto packages and all of their -- dependencies, and eliminating duplicates. - o_file <- readIORef v_Output_file + let o_file = outputFile dflags #if defined(mingw32_HOST_OS) let output_fn = case o_file of { Just s -> s; Nothing -> "main.exe"; } #else @@ -1087,7 +1015,7 @@ staticLink dflags o_files dep_packages = do pkg_lib_paths <- getPackageLibraryPath dflags dep_packages let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths - lib_paths <- readIORef v_Library_paths + let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths pkg_link_opts <- getPackageLinkOpts dflags dep_packages @@ -1110,9 +1038,9 @@ staticLink dflags o_files dep_packages = do extra_ld_inputs <- readIORef v_Ld_inputs -- opts from -optl- (including -l options) - extra_ld_opts <- getStaticOpts v_Opt_l + let extra_ld_opts = getOpts dflags opt_l - ways <- readIORef v_Ways + let ways = wayNames dflags -- Here are some libs that need to be linked at the *end* of -- the command line, because they contain symbols that are referred to @@ -1136,7 +1064,7 @@ staticLink dflags o_files dep_packages = do ] | otherwise = [] - (md_c_flags, _) <- machdepCCOpts dflags + let (md_c_flags, _) = machdepCCOpts dflags SysTools.runLink dflags ( [ SysTools.Option verb , SysTools.Option "-o" @@ -1163,8 +1091,7 @@ staticLink dflags o_files dep_packages = do )) -- parallel only: move binary to another dir -- HWL - ways_ <- readIORef v_Ways - when (WayPar `elem` ways_) + when (WayPar `elem` ways) (do success <- runPhase_MoveBinary output_fn if success then return () else throwDyn (InstallationError ("cannot move binary to PVM dir"))) @@ -1175,16 +1102,15 @@ staticLink dflags o_files dep_packages = do doMkDLL :: DynFlags -> [String] -> [PackageId] -> IO () doMkDLL dflags o_files dep_packages = do let verb = getVerbFlag dflags - static <- readIORef v_Static - no_hs_main <- readIORef v_NoHsMain - - o_file <- readIORef v_Output_file + let static = opt_Static + let no_hs_main = dopt Opt_NoHsMain dflags + let o_file = outputFile dflags let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; } pkg_lib_paths <- getPackageLibraryPath dflags dep_packages let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths - lib_paths <- readIORef v_Library_paths + let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths pkg_link_opts <- getPackageLinkOpts dflags dep_packages @@ -1193,7 +1119,7 @@ doMkDLL dflags o_files dep_packages = do extra_ld_inputs <- readIORef v_Ld_inputs -- opts from -optdll- - extra_ld_opts <- getStaticOpts v_Opt_dll + let extra_ld_opts = getOpts dflags opt_dll let pstate = pkgState dflags rts_id | ExtPackage id <- rtsPackageId pstate = id @@ -1208,7 +1134,7 @@ doMkDLL dflags o_files dep_packages = do else [ head (libraryDirs rts_pkg) ++ "/Main.dll_o", head (libraryDirs base_pkg) ++ "/PrelMain.dll_o" ] - (md_c_flags, _) <- machdepCCOpts dflags + let (md_c_flags, _) = machdepCCOpts dflags SysTools.runMkDLL dflags ([ SysTools.Option verb , SysTools.Option "-o" @@ -1230,13 +1156,12 @@ doMkDLL dflags o_files dep_packages = do )) -- ----------------------------------------------------------------------------- --- Misc. +-- Running CPP doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO () doCpp dflags raw include_cc_opts input_fn output_fn = do let hscpp_opts = getOpts dflags opt_P - - cmdline_include_paths <- readIORef v_Include_paths + let cmdline_include_paths = includePaths dflags pkg_include_dirs <- getPackageIncludePath dflags [] let include_paths = foldr (\ x xs -> "-I" : x : xs) [] @@ -1244,11 +1169,12 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do let verb = getVerbFlag dflags - cc_opts <- if not include_cc_opts - then return [] - else do let optc = getOpts dflags opt_c - (md_c_flags, _) <- machdepCCOpts dflags - return (optc ++ md_c_flags) + let cc_opts + | not include_cc_opts = [] + | otherwise = (optc ++ md_c_flags) + where + optc = getOpts dflags opt_c + (md_c_flags, _) = machdepCCOpts dflags let cpp_prog args | raw = SysTools.runCpp dflags args | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args) @@ -1282,30 +1208,91 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do , SysTools.FileOption "" output_fn ]) +cHaskell1Version = "5" -- i.e., Haskell 98 + +-- Default CPP defines in Haskell source +hsSourceCppOpts = + [ "-D__HASKELL1__="++cHaskell1Version + , "-D__GLASGOW_HASKELL__="++cProjectVersionInt + , "-D__HASKELL98__" + , "-D__CONCURRENT_HASKELL__" + ] + +----------------------------------------------------------------------------- +-- Reading OPTIONS pragmas + +getOptionsFromSource + :: String -- input file + -> IO [String] -- options, if any +getOptionsFromSource file + = do h <- openFile file ReadMode + look h `finally` hClose h + where + look h = do + r <- tryJust ioErrors (hGetLine h) + case r of + Left e | isEOFError e -> return [] + | otherwise -> ioError e + Right l' -> do + let l = removeSpaces l' + case () of + () | null l -> look h + | prefixMatch "#" l -> look h + | prefixMatch "{-# LINE" l -> look h -- -} + | Just opts <- matchOptions l + -> do rest <- look h + return (opts ++ rest) + | otherwise -> return [] + +-- detect {-# OPTIONS_GHC ... #-}. For the time being, we accept OPTIONS +-- instead of OPTIONS_GHC, but that is deprecated. +matchOptions s + | Just s1 <- maybePrefixMatch "{-#" s -- -} + = matchOptions1 (removeSpaces s1) + | otherwise + = Nothing + where + matchOptions1 s + | Just s2 <- maybePrefixMatch "OPTIONS" s + = case () of + _ | Just s3 <- maybePrefixMatch "_GHC" s2, not (is_ident (head s3)) + -> matchOptions2 s3 + | not (is_ident (head s2)) + -> matchOptions2 s2 + | otherwise + -> Just [] -- OPTIONS_anything is ignored, not treated as start of source + | Just s2 <- maybePrefixMatch "INCLUDE" s, not (is_ident (head s2)), + Just s3 <- maybePrefixMatch "}-#" (reverse s2) + = Just ["-#include", removeSpaces (reverse s3)] + | otherwise = Nothing + matchOptions2 s + | Just s3 <- maybePrefixMatch "}-#" (reverse s) = Just (words (reverse s3)) + | otherwise = Nothing + + -- ----------------------------------------------------------------------------- -- Misc. -hscNextPhase :: HscSource -> HscTarget -> IO Phase -hscNextPhase HsBootFile hsc_lang - = return StopLn - -hscNextPhase other hsc_lang = do - split <- readIORef v_Split_object_files - return (case hsc_lang of - HscC -> HCc - HscAsm | split -> SplitMangle - | otherwise -> As - HscNothing -> StopLn - HscInterpreted -> StopLn - _other -> StopLn - ) - -hscMaybeAdjustTarget :: Phase -> HscSource -> HscTarget -> IO HscTarget -hscMaybeAdjustTarget stop HsBootFile current_hsc_lang - = return HscNothing -- No output (other than Foo.hi-boot) for hs-boot files -hscMaybeAdjustTarget stop other current_hsc_lang - = do { keep_hc <- readIORef v_Keep_hc_files - ; let hsc_lang +hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase +hscNextPhase dflags HsBootFile hsc_lang = StopLn +hscNextPhase dflags other hsc_lang = + case hsc_lang of + HscC -> HCc + HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle + | otherwise -> As + HscNothing -> StopLn + HscInterpreted -> StopLn + _other -> StopLn + + +hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget +hscMaybeAdjustTarget dflags stop HsBootFile current_hsc_lang + = HscNothing -- No output (other than Foo.hi-boot) for hs-boot files +hscMaybeAdjustTarget dflags stop other current_hsc_lang + = hsc_lang + where + keep_hc = dopt Opt_KeepHcFiles dflags + hsc_lang -- don't change the lang if we're interpreting | current_hsc_lang == HscInterpreted = current_hsc_lang @@ -1314,4 +1301,6 @@ hscMaybeAdjustTarget stop other current_hsc_lang | keep_hc = HscC -- otherwise, stick to the plan | otherwise = current_hsc_lang - ; return hsc_lang } + +GLOBAL_VAR(v_Split_info, ("",0), (String,Int)) + -- The split prefix and number of files diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs deleted file mode 100644 index 392ed14..0000000 --- a/ghc/compiler/main/DriverState.hs +++ /dev/null @@ -1,534 +0,0 @@ ------------------------------------------------------------------------------ --- --- Settings for the driver --- --- (c) The University of Glasgow 2002 --- ------------------------------------------------------------------------------ - -module DriverState where - -#include "HsVersions.h" - -import CmdLineOpts -import DriverPhases -import DriverUtil -import Util -import Config -import Panic - -import DATA_IOREF ( IORef, readIORef, writeIORef ) -import EXCEPTION - -import List -import Char -import Monad -import Maybe ( fromJust, isJust ) -import Directory ( doesDirectoryExist ) - ------------------------------------------------------------------------------ --- non-configured things - -cHaskell1Version = "5" -- i.e., Haskell 98 - ------------------------------------------------------------------------------ --- GHC modes of operation - -data GhcMode - = DoMkDependHS -- ghc -M - | StopBefore Phase -- ghc -E | -C | -S - -- StopBefore StopLn is the default - | DoMake -- ghc --make - | DoInteractive -- ghc --interactive - | DoEval String -- ghc -e - deriving (Show) - -data GhcLink -- What to do in the link step - = -- Only relevant for modes - -- DoMake and StopBefore StopLn - NoLink -- Don't link at all - | StaticLink -- Ordinary linker [the default] - | MkDLL -- Make a DLL - -GLOBAL_VAR(v_GhcMode, StopBefore StopLn, GhcMode) -GLOBAL_VAR(v_GhcModeFlag, "", String) -GLOBAL_VAR(v_GhcLink, StaticLink, GhcLink) - -setMode :: GhcMode -> String -> IO () -setMode m flag = do - old_mode <- readIORef v_GhcMode - old_flag <- readIORef v_GhcModeFlag - when (notNull old_flag && flag /= old_flag) $ - throwDyn (UsageError - ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'")) - writeIORef v_GhcMode m - writeIORef v_GhcModeFlag flag - -isInteractiveMode, isInterpretiveMode :: GhcMode -> Bool -isMakeMode, isLinkMode, isCompManagerMode :: GhcMode -> Bool - -isInteractiveMode DoInteractive = True -isInteractiveMode _ = False - --- isInterpretiveMode: byte-code compiler involved -isInterpretiveMode DoInteractive = True -isInterpretiveMode (DoEval _) = True -isInterpretiveMode _ = False - -isMakeMode DoMake = True -isMakeMode _ = False - --- True if we are going to attempt to link in this mode. --- (we might not actually link, depending on the GhcLink flag) -isLinkMode (StopBefore StopLn) = True -isLinkMode DoMake = True -isLinkMode _ = False - -isCompManagerMode DoMake = True -isCompManagerMode DoInteractive = True -isCompManagerMode (DoEval _) = True -isCompManagerMode _ = False - -isNoLink :: GhcLink -> Bool -isNoLink NoLink = True -isNoLink other = False - ------------------------------------------------------------------------------ --- Global compilation flags - --- Default CPP defines in Haskell source -hsSourceCppOpts = - [ "-D__HASKELL1__="++cHaskell1Version - , "-D__GLASGOW_HASKELL__="++cProjectVersionInt - , "-D__HASKELL98__" - , "-D__CONCURRENT_HASKELL__" - ] - - --- Keep output from intermediate phases -GLOBAL_VAR(v_Keep_hi_diffs, False, Bool) -GLOBAL_VAR(v_Keep_hc_files, False, Bool) -GLOBAL_VAR(v_Keep_s_files, False, Bool) -GLOBAL_VAR(v_Keep_raw_s_files, False, Bool) -GLOBAL_VAR(v_Keep_tmp_files, False, Bool) -#ifdef ILX -GLOBAL_VAR(v_Keep_il_files, False, Bool) -GLOBAL_VAR(v_Keep_ilx_files, False, Bool) -#endif - --- Misc -GLOBAL_VAR(v_Scale_sizes_by, 1.0, Double) -GLOBAL_VAR(v_Static, True, Bool) -GLOBAL_VAR(v_NoHsMain, False, Bool) -GLOBAL_VAR(v_MainModIs, Nothing, Maybe String) -GLOBAL_VAR(v_MainFunIs, Nothing, Maybe String) -GLOBAL_VAR(v_Collect_ghc_timing, False, Bool) -GLOBAL_VAR(v_Do_asm_mangling, True, Bool) -GLOBAL_VAR(v_Excess_precision, False, Bool) -GLOBAL_VAR(v_Read_DotGHCi, True, Bool) - --- Preprocessor flags -GLOBAL_VAR(v_Hs_source_pp_opts, [], [String]) - ------------------------------------------------------------------------------ --- Splitting object files (for libraries) - -GLOBAL_VAR(v_Split_object_files, False, Bool) -GLOBAL_VAR(v_Split_info, ("",0), (String,Int)) - -- The split prefix and number of files - - -can_split :: Bool -can_split = -#if defined(i386_TARGET_ARCH) \ - || defined(alpha_TARGET_ARCH) \ - || defined(hppa_TARGET_ARCH) \ - || defined(m68k_TARGET_ARCH) \ - || defined(mips_TARGET_ARCH) \ - || defined(powerpc_TARGET_ARCH) \ - || defined(rs6000_TARGET_ARCH) \ - || defined(sparc_TARGET_ARCH) - True -#else - False -#endif - ------------------------------------------------------------------------------ --- Compiler output options - -GLOBAL_VAR(v_Output_dir, Nothing, Maybe String) -GLOBAL_VAR(v_Output_file, Nothing, Maybe String) -GLOBAL_VAR(v_Output_hi, Nothing, Maybe String) - --- called to verify that the output files & directories --- 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 :: IO () -verifyOutputFiles = do - odir <- readIORef v_Output_dir - when (isJust odir) $ do - let dir = fromJust odir - flg <- doesDirectoryExist dir - when (not flg) (nonExistentDir "-odir" dir) - ofile <- readIORef v_Output_file - when (isJust ofile) $ do - let fn = fromJust ofile - flg <- doesDirNameExist fn - when (not flg) (nonExistentDir "-o" fn) - ohi <- readIORef v_Output_hi - when (isJust ohi) $ do - let hi = fromJust ohi - flg <- doesDirNameExist hi - when (not flg) (nonExistentDir "-ohi" hi) - where - nonExistentDir flg dir = - throwDyn (CmdLineError ("error: directory portion of " ++ - show dir ++ " does not exist (used with " ++ - show flg ++ " option.)")) - -GLOBAL_VAR(v_Object_suf, phaseInputExt StopLn, String) -GLOBAL_VAR(v_HC_suf, phaseInputExt HCc, String) -GLOBAL_VAR(v_Hi_dir, Nothing, Maybe String) -GLOBAL_VAR(v_Hi_suf, "hi", String) - -GLOBAL_VAR(v_Ld_inputs, [], [String]) - -odir_ify :: String -> IO String -odir_ify f = do - odir_opt <- readIORef v_Output_dir - case odir_opt of - Nothing -> return f - Just d -> return (replaceFilenameDirectory f d) - -osuf_ify :: String -> IO String -osuf_ify f = do - osuf <- readIORef v_Object_suf - return (replaceFilenameSuffix f osuf) - -GLOBAL_VAR(v_StgStats, False, Bool) - -buildStgToDo :: IO [ StgToDo ] -buildStgToDo = do - stg_stats <- readIORef v_StgStats - let flags1 | stg_stats = [ D_stg_stats ] - | otherwise = [ ] - - -- STG passes - ways_ <- readIORef v_Ways - let flags2 | WayProf `elem` ways_ = StgDoMassageForProfiling : flags1 - | otherwise = flags1 - - return flags2 - ------------------------------------------------------------------------------ --- Paths & Libraries - -split_marker = ':' -- not configurable (ToDo) - -v_Include_paths, v_Library_paths :: IORef [String] -GLOBAL_VAR(v_Include_paths, [], [String]) -GLOBAL_VAR(v_Library_paths, [], [String]) - -#ifdef darwin_TARGET_OS -GLOBAL_VAR(v_Framework_paths, [], [String]) -GLOBAL_VAR(v_Cmdline_frameworks, [], [String]) -#endif - -addToDirList :: IORef [String] -> String -> IO () -addToDirList ref path - = do paths <- readIORef ref - shiny_new_ones <- splitPathList path - writeIORef ref (paths ++ shiny_new_ones) - - -splitPathList :: String -> IO [String] -splitPathList s = do ps <- splitUp s; return (filter notNull ps) - -- empty paths are ignored: there might be a trailing - -- ':' in the initial list, for example. Empty paths can - -- cause confusion when they are translated into -I options - -- for passing to gcc. - where -#ifdef mingw32_TARGET_OS - -- 'hybrid' support for DOS-style paths in directory lists. - -- - -- That is, if "foo:bar:baz" is used, this interpreted as - -- consisting of three entries, 'foo', 'bar', 'baz'. - -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted - -- as four elts, "c:/foo", "c:\\foo", "x", and "/bar" -- - -- *provided* c:/foo exists and x:/bar doesn't. - -- - -- Notice that no attempt is made to fully replace the 'standard' - -- split marker ':' with the Windows / DOS one, ';'. The reason being - -- that this will cause too much breakage for users & ':' will - -- work fine even with DOS paths, if you're not insisting on being silly. - -- So, use either. - splitUp [] = return [] - splitUp (x:':':div:xs) - | div `elem` dir_markers = do - let (p,rs) = findNextPath xs - ps <- splitUp rs - {- - Consult the file system to check the interpretation - of (x:':':div:p) -- this is arguably excessive, we - could skip this test & just say that it is a valid - dir path. - -} - flg <- doesDirectoryExist (x:':':div:p) - if flg then - return ((x:':':div:p):ps) - else - return ([x]:(div:p):ps) - splitUp xs = do - let (p,rs) = findNextPath xs - ps <- splitUp rs - return (cons p ps) - - cons "" xs = xs - cons x xs = x:xs - - -- will be called either when we've consumed nought or the ":/" part of - -- a DOS path, so splitting is just a Q of finding the next split marker. - findNextPath xs = - case break (`elem` split_markers) xs of - (p, d:ds) -> (p, ds) - (p, xs) -> (p, xs) - - split_markers :: [Char] - split_markers = [':', ';'] - - dir_markers :: [Char] - dir_markers = ['/', '\\'] - -#else - splitUp xs = return (split split_marker xs) -#endif - ------------------------------------------------------------------------------ --- Ways - --- The central concept of a "way" is that all objects in a given --- program must be compiled in the same "way". Certain options change --- parameters of the virtual machine, eg. profiling adds an extra word --- to the object header, so profiling objects cannot be linked with --- non-profiling objects. - --- After parsing the command-line options, we determine which "way" we --- are building - this might be a combination way, eg. profiling+ticky-ticky. - --- We then find the "build-tag" associated with this way, and this --- becomes the suffix used to find .hi files and libraries used in --- this compilation. - -GLOBAL_VAR(v_Build_tag, "", String) - --- The RTS has its own build tag, because there are some ways that --- affect the RTS only. -GLOBAL_VAR(v_RTS_Build_tag, "", String) - -data WayName - = WayThreaded - | WayDebug - | WayProf - | WayUnreg - | WayTicky - | WayPar - | WayGran - | WaySMP - | WayNDP - | WayUser_a - | WayUser_b - | WayUser_c - | WayUser_d - | WayUser_e - | WayUser_f - | WayUser_g - | WayUser_h - | WayUser_i - | WayUser_j - | WayUser_k - | WayUser_l - | WayUser_m - | WayUser_n - | WayUser_o - | WayUser_A - | WayUser_B - deriving (Eq,Ord) - -GLOBAL_VAR(v_Ways, [] ,[WayName]) - -allowed_combination way = and [ x `allowedWith` y - | x <- way, y <- way, x < y ] - where - -- Note ordering in these tests: the left argument is - -- <= the right argument, according to the Ord instance - -- on Way above. - - -- debug is allowed with everything - _ `allowedWith` WayDebug = True - WayDebug `allowedWith` _ = True - - WayThreaded `allowedWith` WayProf = True - WayProf `allowedWith` WayUnreg = True - WayProf `allowedWith` WaySMP = True - WayProf `allowedWith` WayNDP = True - _ `allowedWith` _ = False - - -findBuildTag :: IO [String] -- new options -findBuildTag = do - way_names <- readIORef v_Ways - let ws = sort way_names - if not (allowed_combination ws) - then throwDyn (CmdLineError $ - "combination not supported: " ++ - foldr1 (\a b -> a ++ '/':b) - (map (wayName . lkupWay) ws)) - else let ways = map lkupWay ws - tag = mkBuildTag (filter (not.wayRTSOnly) ways) - rts_tag = mkBuildTag ways - flags = map wayOpts ways - in do - writeIORef v_Build_tag tag - writeIORef v_RTS_Build_tag rts_tag - return (concat flags) - -mkBuildTag :: [Way] -> String -mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) - -lkupWay w = - case lookup w way_details of - Nothing -> error "findBuildTag" - Just details -> details - -data Way = Way { - wayTag :: String, - wayRTSOnly :: Bool, - wayName :: String, - wayOpts :: [String] - } - -way_details :: [ (WayName, Way) ] -way_details = - [ (WayThreaded, Way "thr" True "Threaded" [ -#if defined(freebsd_TARGET_OS) - "-optc-pthread" - , "-optl-pthread" -#endif - ] ), - - (WayDebug, Way "debug" True "Debug" [] ), - - (WayProf, Way "p" False "Profiling" - [ "-fscc-profiling" - , "-DPROFILING" - , "-optc-DPROFILING" - , "-fvia-C" ]), - - (WayTicky, Way "t" False "Ticky-ticky Profiling" - [ "-fticky-ticky" - , "-DTICKY_TICKY" - , "-optc-DTICKY_TICKY" - , "-fvia-C" ]), - - (WayUnreg, Way "u" False "Unregisterised" - unregFlags ), - - -- optl's below to tell linker where to find the PVM library -- HWL - (WayPar, Way "mp" False "Parallel" - [ "-fparallel" - , "-D__PARALLEL_HASKELL__" - , "-optc-DPAR" - , "-package concurrent" - , "-optc-w" - , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" - , "-optl-lpvm3" - , "-optl-lgpvm3" - , "-fvia-C" ]), - - -- at the moment we only change the RTS and could share compiler and libs! - (WayPar, Way "mt" False "Parallel ticky profiling" - [ "-fparallel" - , "-D__PARALLEL_HASKELL__" - , "-optc-DPAR" - , "-optc-DPAR_TICKY" - , "-package concurrent" - , "-optc-w" - , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" - , "-optl-lpvm3" - , "-optl-lgpvm3" - , "-fvia-C" ]), - - (WayPar, Way "md" False "Distributed" - [ "-fparallel" - , "-D__PARALLEL_HASKELL__" - , "-D__DISTRIBUTED_HASKELL__" - , "-optc-DPAR" - , "-optc-DDIST" - , "-package concurrent" - , "-optc-w" - , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" - , "-optl-lpvm3" - , "-optl-lgpvm3" - , "-fvia-C" ]), - - (WayGran, Way "mg" False "GranSim" - [ "-fgransim" - , "-D__GRANSIM__" - , "-optc-DGRAN" - , "-package concurrent" - , "-fvia-C" ]), - - (WaySMP, Way "s" False "SMP" - [ "-fsmp" - , "-optc-pthread" -#ifndef freebsd_TARGET_OS - , "-optl-pthread" -#endif - , "-optc-DSMP" - , "-fvia-C" ]), - - (WayNDP, Way "ndp" False "Nested data parallelism" - [ "-fparr" - , "-fflatten"]), - - (WayUser_a, Way "a" False "User way 'a'" ["$WAY_a_REAL_OPTS"]), - (WayUser_b, Way "b" False "User way 'b'" ["$WAY_b_REAL_OPTS"]), - (WayUser_c, Way "c" False "User way 'c'" ["$WAY_c_REAL_OPTS"]), - (WayUser_d, Way "d" False "User way 'd'" ["$WAY_d_REAL_OPTS"]), - (WayUser_e, Way "e" False "User way 'e'" ["$WAY_e_REAL_OPTS"]), - (WayUser_f, Way "f" False "User way 'f'" ["$WAY_f_REAL_OPTS"]), - (WayUser_g, Way "g" False "User way 'g'" ["$WAY_g_REAL_OPTS"]), - (WayUser_h, Way "h" False "User way 'h'" ["$WAY_h_REAL_OPTS"]), - (WayUser_i, Way "i" False "User way 'i'" ["$WAY_i_REAL_OPTS"]), - (WayUser_j, Way "j" False "User way 'j'" ["$WAY_j_REAL_OPTS"]), - (WayUser_k, Way "k" False "User way 'k'" ["$WAY_k_REAL_OPTS"]), - (WayUser_l, Way "l" False "User way 'l'" ["$WAY_l_REAL_OPTS"]), - (WayUser_m, Way "m" False "User way 'm'" ["$WAY_m_REAL_OPTS"]), - (WayUser_n, Way "n" False "User way 'n'" ["$WAY_n_REAL_OPTS"]), - (WayUser_o, Way "o" False "User way 'o'" ["$WAY_o_REAL_OPTS"]), - (WayUser_A, Way "A" False "User way 'A'" ["$WAY_A_REAL_OPTS"]), - (WayUser_B, Way "B" False "User way 'B'" ["$WAY_B_REAL_OPTS"]) - ] - -unregFlags = - [ "-optc-DNO_REGS" - , "-optc-DUSE_MINIINTERPRETER" - , "-fno-asm-mangling" - , "-funregisterised" - , "-fvia-C" ] - ------------------------------------------------------------------------------ --- Options for particular phases - -GLOBAL_VAR(v_Opt_dep, [], [String]) -GLOBAL_VAR(v_Anti_opt_C, [], [String]) -GLOBAL_VAR(v_Opt_C, [], [String]) -GLOBAL_VAR(v_Opt_l, [], [String]) -GLOBAL_VAR(v_Opt_dll, [], [String]) - -getStaticOpts :: IORef [String] -> IO [String] -getStaticOpts ref = readIORef ref >>= return . reverse diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs deleted file mode 100644 index 0941136..0000000 --- a/ghc/compiler/main/DriverUtil.hs +++ /dev/null @@ -1,255 +0,0 @@ ------------------------------------------------------------------------------ --- $Id: DriverUtil.hs,v 1.51 2005/01/28 14:27:00 simonmar Exp $ --- --- Utils for the driver --- --- (c) The University of Glasgow 2000 --- ------------------------------------------------------------------------------ - -module DriverUtil ( - getOptionsFromSource, softGetDirectoryContents, - createDirectoryHierarchy, doesDirNameExist, prefixUnderscore, - unknownFlagErr, unknownFlagsErr, missingArgErr, - later, handleDyn, handle, - split, add, addNoDups, - Suffix, splitFilename, getFileSuffix, - splitFilename3, remove_suffix, split_longest_prefix, - replaceFilenameSuffix, directoryOf, filenameOf, - replaceFilenameDirectory, remove_spaces, escapeSpaces, - ) where - -#include "HsVersions.h" - -import Util -import Panic -import Config ( cLeadingUnderscore ) -import Ctype - -import EXCEPTION ( Exception(..), finally, throwDyn, catchDyn, throw ) -import qualified EXCEPTION as Exception -import DYNAMIC -import DATA_IOREF ( IORef, readIORef, writeIORef ) - -import Directory -import IO -import List -import Char -import Monad - ------------------------------------------------------------------------------ --- Reading OPTIONS pragmas - -getOptionsFromSource - :: String -- input file - -> IO [String] -- options, if any -getOptionsFromSource file - = do h <- openFile file ReadMode - look h `finally` hClose h - where - look h = do - r <- tryJust ioErrors (hGetLine h) - case r of - Left e | isEOFError e -> return [] - | otherwise -> ioError e - Right l' -> do - let l = remove_spaces l' - case () of - () | null l -> look h - | prefixMatch "#" l -> look h - | prefixMatch "{-# LINE" l -> look h -- -} - | Just opts <- matchOptions l - -> do rest <- look h - return (opts ++ rest) - | otherwise -> return [] - --- detect {-# OPTIONS_GHC ... #-}. For the time being, we accept OPTIONS --- instead of OPTIONS_GHC, but that is deprecated. -matchOptions s - | Just s1 <- maybePrefixMatch "{-#" s -- -} - = matchOptions1 (remove_spaces s1) - | otherwise - = Nothing - where - matchOptions1 s - | Just s2 <- maybePrefixMatch "OPTIONS" s - = case () of - _ | Just s3 <- maybePrefixMatch "_GHC" s2, not (is_ident (head s3)) - -> matchOptions2 s3 - | not (is_ident (head s2)) - -> matchOptions2 s2 - | otherwise - -> Just [] -- OPTIONS_anything is ignored, not treated as start of source - | Just s2 <- maybePrefixMatch "INCLUDE" s, not (is_ident (head s2)), - Just s3 <- maybePrefixMatch "}-#" (reverse s2) - = Just ["-#include", remove_spaces (reverse s3)] - | otherwise = Nothing - matchOptions2 s - | Just s3 <- maybePrefixMatch "}-#" (reverse s) = Just (words (reverse s3)) - | otherwise = Nothing - ------------------------------------------------------------------------------ --- A version of getDirectoryContents that is non-fatal if the --- directory doesn't exist. - -softGetDirectoryContents d - = IO.catch (getDirectoryContents d) - (\_ -> do hPutStrLn stderr - ("WARNING: error while reading directory " ++ d) - return [] - ) - ------------------------------------------------------------------------------ --- Create a hierarchy of directories - -createDirectoryHierarchy :: FilePath -> IO () -createDirectoryHierarchy dir = do - b <- doesDirectoryExist dir - when (not b) $ do - createDirectoryHierarchy (directoryOf dir) - createDirectory dir - ------------------------------------------------------------------------------ --- Verify that the 'dirname' portion of a FilePath exists. --- -doesDirNameExist :: FilePath -> IO Bool -doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath) - ------------------------------------------------------------------------------ --- Prefixing underscore to linker-level names -prefixUnderscore :: String -> String -prefixUnderscore - | cLeadingUnderscore == "YES" = ('_':) - | otherwise = id - ------------------------------------------------------------------------------ --- Utils - -unknownFlagErr :: String -> a -unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f)) - -unknownFlagsErr :: [String] -> a -unknownFlagsErr fs = throwDyn (UsageError ("unrecognised flags: " ++ unwords fs)) - -missingArgErr :: String -> a -missingArgErr f = throwDyn (UsageError ("missing argument for flag: " ++ f)) - -later = flip finally - -handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a -handleDyn = flip catchDyn - -handle :: (Exception -> IO a) -> IO a -> IO a -#if __GLASGOW_HASKELL__ < 501 -handle = flip Exception.catchAllIO -#else -handle h f = f `Exception.catch` \e -> case e of - ExitException _ -> throw e - _ -> h e -#endif - -split :: Char -> String -> [String] -split c s = case rest of - [] -> [chunk] - _:rest -> chunk : split c rest - where (chunk, rest) = break (==c) s - -add :: IORef [a] -> a -> IO () -add var x = do - xs <- readIORef var - writeIORef var (x:xs) - -addNoDups :: Eq a => IORef [a] -> a -> IO () -addNoDups var x = do - xs <- readIORef var - unless (x `elem` xs) $ writeIORef var (x:xs) - ------------------------------------------------------- --- Filename manipulation ------------------------------------------------------- - -type Suffix = String - -splitFilename :: String -> (String,Suffix) -splitFilename f = split_longest_prefix f (=='.') - -getFileSuffix :: String -> Suffix -getFileSuffix f = drop_longest_prefix f (=='.') - --- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext") -splitFilenameDir :: String -> (String,String) -splitFilenameDir str - = let (dir, rest) = split_longest_prefix str isPathSeparator - real_dir | null dir = "." - | otherwise = dir - in (real_dir, rest) - --- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext") -splitFilename3 :: String -> (String,String,Suffix) -splitFilename3 str - = let (dir, rest) = split_longest_prefix str isPathSeparator - (name, ext) = splitFilename rest - real_dir | null dir = "." - | otherwise = dir - in (real_dir, name, ext) - -remove_suffix :: Char -> String -> Suffix -remove_suffix c s - | null pre = s - | otherwise = reverse pre - where (suf,pre) = break (==c) (reverse s) - -drop_longest_prefix :: String -> (Char -> Bool) -> String -drop_longest_prefix s pred = reverse suf - where (suf,_pre) = break pred (reverse s) - -take_longest_prefix :: String -> (Char -> Bool) -> String -take_longest_prefix s pred = reverse pre - where (_suf,pre) = break pred (reverse s) - --- split a string at the last character where 'pred' is True, --- returning a pair of strings. The first component holds the string --- up (but not including) the last character for which 'pred' returned --- True, the second whatever comes after (but also not including the --- last character). --- --- If 'pred' returns False for all characters in the string, the original --- string is returned in the second component (and the first one is just --- empty). -split_longest_prefix :: String -> (Char -> Bool) -> (String,String) -split_longest_prefix s pred - = case pre of - [] -> ([], reverse suf) - (_:pre) -> (reverse pre, reverse suf) - where (suf,pre) = break pred (reverse s) - -replaceFilenameSuffix :: FilePath -> Suffix -> FilePath -replaceFilenameSuffix s suf = remove_suffix '.' s ++ suf - --- directoryOf strips the filename off the input string, returning --- the directory. -directoryOf :: FilePath -> String -directoryOf = fst . splitFilenameDir - --- filenameOf strips the directory off the input string, returning --- the filename. -filenameOf :: FilePath -> String -filenameOf = snd . splitFilenameDir - -replaceFilenameDirectory :: FilePath -> String -> FilePath -replaceFilenameDirectory s dir - = dir ++ '/':drop_longest_prefix s isPathSeparator - -remove_spaces :: String -> String -remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace - -escapeSpaces :: String -> String -escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) "" - -isPathSeparator :: Char -> Bool -isPathSeparator ch = -#ifdef mingw32_TARGET_OS - ch == '/' || ch == '\\' -#else - ch == '/' -#endif diff --git a/ghc/compiler/main/DynFlags.hs b/ghc/compiler/main/DynFlags.hs new file mode 100644 index 0000000..62d269d --- /dev/null +++ b/ghc/compiler/main/DynFlags.hs @@ -0,0 +1,1230 @@ +----------------------------------------------------------------------------- +-- +-- Dynamic flags +-- +-- Most flags are dynamic flags, which means they can change from +-- compilation to compilation using OPTIONS_GHC pragmas, and in a +-- multi-session GHC each session can be using different dynamic +-- flags. Dynamic flags can also be set at the prompt in GHCi. +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module DynFlags ( + -- Dynamic flags + DynFlag(..), + DynFlags(..), + HscTarget(..), + GhcMode(..), isOneShot, + GhcLink(..), isNoLink, + PackageFlag(..), + Option(..), + + -- Configuration of the core-to-core and stg-to-stg phases + CoreToDo(..), + StgToDo(..), + SimplifierSwitch(..), + SimplifierMode(..), FloatOutSwitches(..), + getCoreToDo, getStgToDo, + + -- Manipulating DynFlags + defaultDynFlags, -- DynFlags + initDynFlags, -- DynFlags -> IO DynFlags + + dopt, -- DynFlag -> DynFlags -> Bool + dopt_set, dopt_unset, -- DynFlags -> DynFlag -> DynFlags + getOpts, -- (DynFlags -> [a]) -> IO [a] + getVerbFlag, + updOptLevel, + + -- parsing DynFlags + parseDynamicFlags, + + -- misc stuff + machdepCCOpts, picCCOpts, + ) where + +#include "HsVersions.h" + +import StaticFlags ( opt_Static, opt_PIC, + WayName(..), v_Ways, v_Build_tag, v_RTS_Build_tag ) +import {-# SOURCE #-} Packages (PackageState) +import DriverPhases ( Phase(..), phaseInputExt ) +import Config +import CmdLineParser +import Panic ( panic, GhcException(..) ) +import Util ( notNull, splitLongestPrefix, split ) + +import DATA_IOREF ( readIORef ) +import EXCEPTION ( throwDyn ) +import Monad ( when ) +import Maybe ( fromJust ) +import Char ( isDigit, isUpper ) + +-- ----------------------------------------------------------------------------- +-- DynFlags + +data DynFlag + + -- debugging flags + = Opt_D_dump_cmm + | Opt_D_dump_asm + | Opt_D_dump_cpranal + | Opt_D_dump_deriv + | Opt_D_dump_ds + | Opt_D_dump_flatC + | Opt_D_dump_foreign + | Opt_D_dump_inlinings + | Opt_D_dump_occur_anal + | Opt_D_dump_parsed + | Opt_D_dump_rn + | Opt_D_dump_simpl + | Opt_D_dump_simpl_iterations + | Opt_D_dump_spec + | Opt_D_dump_prep + | Opt_D_dump_stg + | Opt_D_dump_stranal + | Opt_D_dump_tc + | Opt_D_dump_types + | Opt_D_dump_rules + | Opt_D_dump_cse + | Opt_D_dump_worker_wrapper + | Opt_D_dump_rn_trace + | Opt_D_dump_rn_stats + | Opt_D_dump_opt_cmm + | Opt_D_dump_simpl_stats + | Opt_D_dump_tc_trace + | Opt_D_dump_if_trace + | Opt_D_dump_splices + | Opt_D_dump_BCOs + | Opt_D_dump_vect + | Opt_D_source_stats + | Opt_D_verbose_core2core + | Opt_D_verbose_stg2stg + | Opt_D_dump_hi + | Opt_D_dump_hi_diffs + | Opt_D_dump_minimal_imports + | Opt_DoCoreLinting + | Opt_DoStgLinting + | Opt_DoCmmLinting + + | Opt_WarnIsError -- -Werror; makes warnings fatal + | Opt_WarnDuplicateExports + | Opt_WarnHiShadows + | Opt_WarnIncompletePatterns + | Opt_WarnIncompletePatternsRecUpd + | Opt_WarnMissingFields + | Opt_WarnMissingMethods + | Opt_WarnMissingSigs + | Opt_WarnNameShadowing + | Opt_WarnOverlappingPatterns + | Opt_WarnSimplePatterns + | Opt_WarnTypeDefaults + | Opt_WarnUnusedBinds + | Opt_WarnUnusedImports + | Opt_WarnUnusedMatches + | Opt_WarnDeprecations + | Opt_WarnDodgyImports + | Opt_WarnOrphans + + -- language opts + | Opt_AllowOverlappingInstances + | Opt_AllowUndecidableInstances + | Opt_AllowIncoherentInstances + | Opt_MonomorphismRestriction + | Opt_GlasgowExts + | Opt_FFI + | Opt_PArr -- syntactic support for parallel arrays + | Opt_Arrows -- Arrow-notation syntax + | Opt_TH + | Opt_ImplicitParams + | Opt_Generics + | Opt_ImplicitPrelude + | Opt_ScopedTypeVariables + + -- optimisation opts + | Opt_Strictness + | Opt_FullLaziness + | Opt_CSE + | Opt_IgnoreInterfacePragmas + | Opt_OmitInterfacePragmas + | Opt_DoLambdaEtaExpansion + | Opt_IgnoreAsserts + | Opt_DoEtaReduction + | Opt_CaseMerge + | Opt_UnboxStrictFields + + -- misc opts + | Opt_Cpp + | Opt_Pp + | Opt_RecompChecking + | Opt_DryRun + | Opt_DoAsmMangling + | Opt_ExcessPrecision + | Opt_ReadUserPackageConf + | Opt_NoHsMain + | Opt_SplitObjs + | Opt_StgStats + + -- keeping stuff + | Opt_KeepHiDiffs + | Opt_KeepHcFiles + | Opt_KeepSFiles + | Opt_KeepRawSFiles + | Opt_KeepTmpFiles + + deriving (Eq) + +data DynFlags = DynFlags { + ghcMode :: GhcMode, + ghcLink :: GhcLink, + coreToDo :: Maybe [CoreToDo], -- reserved for -Ofile + stgToDo :: Maybe [StgToDo], -- similarly + hscTarget :: HscTarget, + hscOutName :: String, -- name of the output file + hscStubHOutName :: String, -- name of the .stub_h output file + hscStubCOutName :: String, -- name of the .stub_c output file + extCoreName :: String, -- name of the .core output file + verbosity :: Int, -- verbosity level + optLevel :: Int, -- optimisation level + maxSimplIterations :: Int, -- max simplifier iterations + ruleCheck :: Maybe String, + stolen_x86_regs :: Int, + cmdlineHcIncludes :: [String], -- -#includes + importPaths :: [FilePath], + mainModIs :: Maybe String, + mainFunIs :: Maybe String, + + -- ways + wayNames :: [WayName], -- way flags from the cmd line + buildTag :: String, -- the global "way" (eg. "p" for prof) + rtsBuildTag :: String, -- the RTS "way" + + -- paths etc. + outputDir :: Maybe String, + outputFile :: Maybe String, + outputHi :: Maybe String, + objectSuf :: String, + hcSuf :: String, + hiDir :: Maybe String, + hiSuf :: String, + includePaths :: [String], + libraryPaths :: [String], + frameworkPaths :: [String], -- used on darwin only + cmdlineFrameworks :: [String], -- ditto + tmpDir :: String, + + -- 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_dll :: [String], + opt_dep :: [String], + + -- 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]), + + -- ** Package flags + extraPkgConfs :: [FilePath], + -- The -package-conf flags given on the command line, in the order + -- they appeared. + + packageFlags :: [PackageFlag], + -- The -package and -hide-package flags from the command-line + + -- ** Package state + pkgState :: PackageState, + + -- hsc dynamic flags + flags :: [DynFlag] + } + +data HscTarget + = HscC + | HscAsm + | HscJava + | HscILX + | HscInterpreted + | HscNothing + deriving (Eq, Show) + +data GhcMode + = BatchCompile -- | @ghc --make Main@ + | Interactive -- | @ghc --interactive@ + | OneShot -- | @ghc -c Foo.hs@ + | JustTypecheck -- | Development environemnts, refactorer, etc. + | MkDepend + deriving Eq + +isOneShot :: GhcMode -> Bool +isOneShot OneShot = True +isOneShot _other = False + +data GhcLink -- What to do in the link step, if there is one + = -- Only relevant for modes + -- DoMake and StopBefore StopLn + NoLink -- Don't link at all + | StaticLink -- Ordinary linker [the default] + | MkDLL -- Make a DLL + +isNoLink :: GhcLink -> Bool +isNoLink NoLink = True +isNoLink other = False + +data PackageFlag + = ExposePackage String + | HidePackage String + | IgnorePackage String + +defaultHscTarget +#if defined(i386_TARGET_ARCH) || defined(sparc_TARGET_ARCH) || defined(powerpc_TARGET_ARCH) + | cGhcWithNativeCodeGen == "YES" = HscAsm +#endif + | otherwise = HscC + +initDynFlags dflags = do + -- someday these will be dynamic flags + ways <- readIORef v_Ways + build_tag <- readIORef v_Build_tag + rts_build_tag <- readIORef v_RTS_Build_tag + return dflags{ + wayNames = ways, + buildTag = build_tag, + rtsBuildTag = rts_build_tag + } + +defaultDynFlags = + DynFlags { + ghcMode = OneShot, + ghcLink = StaticLink, + coreToDo = Nothing, + stgToDo = Nothing, + hscTarget = defaultHscTarget, + hscOutName = "", + hscStubHOutName = "", + hscStubCOutName = "", + extCoreName = "", + verbosity = 0, + optLevel = 0, + maxSimplIterations = 4, + ruleCheck = Nothing, + stolen_x86_regs = 4, + cmdlineHcIncludes = [], + importPaths = ["."], + mainModIs = Nothing, + mainFunIs = Nothing, + + wayNames = panic "ways", + buildTag = panic "buildTag", + rtsBuildTag = panic "rtsBuildTag", + + outputDir = Nothing, + outputFile = Nothing, + outputHi = Nothing, + objectSuf = phaseInputExt StopLn, + hcSuf = phaseInputExt HCc, + hiDir = Nothing, + hiSuf = "hi", + includePaths = [], + libraryPaths = [], + frameworkPaths = [], + cmdlineFrameworks = [], + tmpDir = [], + + opt_L = [], + opt_P = [], + opt_F = [], + opt_c = [], + opt_a = [], + opt_m = [], + opt_l = [], + opt_dll = [], + opt_dep = [], + + pgm_L = panic "pgm_L", + pgm_P = panic "pgm_P", + pgm_F = panic "pgm_F", + pgm_c = panic "pgm_c", + pgm_m = panic "pgm_m", + pgm_s = panic "pgm_s", + pgm_a = panic "pgm_a", + pgm_l = panic "pgm_l", + pgm_dll = panic "pgm_mkdll", + + extraPkgConfs = [], + packageFlags = [], + pkgState = panic "pkgState", + + flags = [ + Opt_RecompChecking, + Opt_ReadUserPackageConf, + + Opt_ImplicitPrelude, + Opt_MonomorphismRestriction, + Opt_Strictness, + -- strictness is on by default, but this only + -- applies to -O. + Opt_CSE, -- similarly for CSE. + Opt_FullLaziness, -- ...and for full laziness + + Opt_DoLambdaEtaExpansion, + -- This one is important for a tiresome reason: + -- we want to make sure that the bindings for data + -- constructors are eta-expanded. This is probably + -- a good thing anyway, but it seems fragile. + + Opt_DoAsmMangling, + + -- and the default no-optimisation options: + Opt_IgnoreInterfacePragmas, + Opt_OmitInterfacePragmas + + ] ++ standardWarnings + } + +{- + Verbosity levels: + + 0 | print errors & warnings only + 1 | minimal verbosity: print "compiling M ... done." for each module. + 2 | equivalent to -dshow-passes + 3 | equivalent to existing "ghc -v" + 4 | "ghc -v -ddump-most" + 5 | "ghc -v -ddump-all" +-} + +dopt :: DynFlag -> DynFlags -> Bool +dopt f dflags = f `elem` (flags dflags) + +dopt_set :: DynFlags -> DynFlag -> DynFlags +dopt_set dfs f = dfs{ flags = f : flags dfs } + +dopt_unset :: DynFlags -> DynFlag -> DynFlags +dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) } + +getOpts :: DynFlags -> (DynFlags -> [a]) -> [a] +getOpts dflags opts = reverse (opts dflags) + -- We add to the options from the front, so we need to reverse the list + +getVerbFlag :: DynFlags -> String +getVerbFlag dflags + | verbosity dflags >= 3 = "-v" + | otherwise = "" + +setOutputDir f d = d{ outputDir = f} +setOutputFile f d = d{ outputFile = f} +setOutputHi f d = d{ outputHi = f} +setObjectSuf f d = d{ objectSuf = f} +setHcSuf f d = d{ hcSuf = f} +setHiSuf f d = d{ hiSuf = f} +setHiDir f d = d{ hiDir = f} +setTmpDir f d = d{ tmpDir = f} + +-- 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)} + +setPgmL f d = d{ pgm_L = f} +setPgmF f d = d{ pgm_F = f} +setPgmc f d = d{ pgm_c = (f,[])} +setPgmm f d = d{ pgm_m = (f,[])} +setPgms f d = d{ pgm_s = (f,[])} +setPgma f d = d{ pgm_a = (f,[])} +setPgml f d = d{ pgm_l = (f,[])} +setPgmdll f d = d{ pgm_dll = (f,[])} + +addOptL f d = d{ opt_L = f : opt_L d} +addOptP f d = d{ opt_P = f : opt_P d} +addOptF f d = d{ opt_F = f : opt_F d} +addOptc f d = d{ opt_c = f : opt_c d} +addOptm f d = d{ opt_m = f : opt_m d} +addOpta f d = d{ opt_a = f : opt_a d} +addOptl f d = d{ opt_l = f : opt_l d} +addOptdll f d = d{ opt_dll = f : opt_dll d} +addOptdep f d = d{ opt_dep = f : opt_dep d} + +addCmdlineFramework f d = d{ cmdlineFrameworks = f : cmdlineFrameworks d} + +-- ----------------------------------------------------------------------------- +-- Command-line options + +-- When invoking external tools as part of the compilation pipeline, we +-- pass these a sequence of options on the command-line. Rather than +-- just using a list of Strings, we use a type that allows us to distinguish +-- between filepaths and 'other stuff'. [The reason being, of course, that +-- this type gives us a handle on transforming filenames, and filenames only, +-- to whatever format they're expected to be on a particular platform.] + +data Option + = FileOption -- an entry that _contains_ filename(s) / filepaths. + String -- a non-filepath prefix that shouldn't be + -- transformed (e.g., "/out=") + String -- the filepath/filename portion + | Option String + +----------------------------------------------------------------------------- +-- Setting the optimisation level + +updOptLevel :: Int -> DynFlags -> DynFlags +-- Set dynflags appropriate to the optimisation level +updOptLevel n dfs + = if (n >= 1) + then dfs2{ hscTarget = HscC, optLevel = n } -- turn on -fvia-C with -O + else dfs2{ optLevel = n } + where + dfs1 = foldr (flip dopt_unset) dfs remove_dopts + dfs2 = foldr (flip dopt_set) dfs1 extra_dopts + + extra_dopts + | n == 0 = opt_0_dopts + | otherwise = opt_1_dopts + + remove_dopts + | n == 0 = opt_1_dopts + | otherwise = opt_0_dopts + +opt_0_dopts = [ + Opt_IgnoreInterfacePragmas, + Opt_OmitInterfacePragmas + ] + +opt_1_dopts = [ + Opt_IgnoreAsserts, + Opt_DoEtaReduction, + Opt_CaseMerge + ] + +-- ----------------------------------------------------------------------------- +-- Standard sets of warning options + +standardWarnings + = [ Opt_WarnDeprecations, + Opt_WarnOverlappingPatterns, + Opt_WarnMissingFields, + Opt_WarnMissingMethods, + Opt_WarnDuplicateExports + ] + +minusWOpts + = standardWarnings ++ + [ Opt_WarnUnusedBinds, + Opt_WarnUnusedMatches, + Opt_WarnUnusedImports, + Opt_WarnIncompletePatterns, + Opt_WarnDodgyImports + ] + +minusWallOpts + = minusWOpts ++ + [ Opt_WarnTypeDefaults, + Opt_WarnNameShadowing, + Opt_WarnMissingSigs, + Opt_WarnHiShadows, + Opt_WarnOrphans + ] + +-- ----------------------------------------------------------------------------- +-- CoreToDo: abstraction of core-to-core passes to run. + +data CoreToDo -- These are diff core-to-core passes, + -- which may be invoked in any order, + -- as many times as you like. + + = CoreDoSimplify -- The core-to-core simplifier. + SimplifierMode + [SimplifierSwitch] + -- Each run of the simplifier can take a different + -- set of simplifier-specific flags. + | CoreDoFloatInwards + | CoreDoFloatOutwards FloatOutSwitches + | CoreLiberateCase + | CoreDoPrintCore + | CoreDoStaticArgs + | CoreDoStrictness + | CoreDoWorkerWrapper + | CoreDoSpecialising + | CoreDoSpecConstr + | CoreDoOldStrictness + | CoreDoGlomBinds + | CoreCSE + | CoreDoRuleCheck Int{-CompilerPhase-} String -- Check for non-application of rules + -- matching this string + + | CoreDoNothing -- useful when building up lists of these things + +data SimplifierMode -- See comments in SimplMonad + = SimplGently + | SimplPhase Int + +data SimplifierSwitch + = MaxSimplifierIterations Int + | NoCaseOfCase + +data FloatOutSwitches + = FloatOutSw Bool -- True <=> float lambdas to top level + Bool -- True <=> float constants to top level, + -- even if they do not escape a lambda + + +-- The core-to-core pass ordering is derived from the DynFlags: + +getCoreToDo :: DynFlags -> [CoreToDo] +getCoreToDo dflags + | Just todo <- coreToDo dflags = todo -- set explicitly by user + | otherwise = core_todo + where + opt_level = optLevel dflags + max_iter = maxSimplIterations dflags + strictness = dopt Opt_Strictness dflags + full_laziness = dopt Opt_FullLaziness dflags + cse = dopt Opt_CSE dflags + rule_check = ruleCheck dflags + + core_todo = + if opt_level == 0 then + [ + CoreDoSimplify (SimplPhase 0) [ + MaxSimplifierIterations max_iter + ] + ] + + else {- opt_level >= 1 -} [ + + -- initial simplify: mk specialiser happy: minimum effort please + CoreDoSimplify SimplGently [ + -- Simplify "gently" + -- Don't inline anything till full laziness has bitten + -- In particular, inlining wrappers inhibits floating + -- e.g. ...(case f x of ...)... + -- ==> ...(case (case x of I# x# -> fw x#) of ...)... + -- ==> ...(case x of I# x# -> case fw x# of ...)... + -- and now the redex (f x) isn't floatable any more + -- Similarly, don't apply any rules until after full + -- laziness. Notably, list fusion can prevent floating. + + NoCaseOfCase, + -- Don't do case-of-case transformations. + -- This makes full laziness work better + MaxSimplifierIterations max_iter + ], + + -- Specialisation is best done before full laziness + -- so that overloaded functions have all their dictionary lambdas manifest + CoreDoSpecialising, + + if full_laziness then CoreDoFloatOutwards (FloatOutSw False False) + else CoreDoNothing, + + CoreDoFloatInwards, + + CoreDoSimplify (SimplPhase 2) [ + -- Want to run with inline phase 2 after the specialiser to give + -- maximum chance for fusion to work before we inline build/augment + -- in phase 1. This made a difference in 'ansi' where an + -- overloaded function wasn't inlined till too late. + MaxSimplifierIterations max_iter + ], + case rule_check of { Just pat -> CoreDoRuleCheck 2 pat; Nothing -> CoreDoNothing }, + + CoreDoSimplify (SimplPhase 1) [ + -- Need inline-phase2 here so that build/augment get + -- inlined. I found that spectral/hartel/genfft lost some useful + -- strictness in the function sumcode' if augment is not inlined + -- before strictness analysis runs + MaxSimplifierIterations max_iter + ], + case rule_check of { Just pat -> CoreDoRuleCheck 1 pat; Nothing -> CoreDoNothing }, + + CoreDoSimplify (SimplPhase 0) [ + -- Phase 0: allow all Ids to be inlined now + -- This gets foldr inlined before strictness analysis + + MaxSimplifierIterations 3 + -- At least 3 iterations because otherwise we land up with + -- huge dead expressions because of an infelicity in the + -- simpifier. + -- let k = BIG in foldr k z xs + -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs + -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs + -- Don't stop now! + + ], + case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing }, + +#ifdef OLD_STRICTNESS + CoreDoOldStrictness +#endif + if strictness then CoreDoStrictness else CoreDoNothing, + CoreDoWorkerWrapper, + CoreDoGlomBinds, + + CoreDoSimplify (SimplPhase 0) [ + MaxSimplifierIterations max_iter + ], + + if full_laziness then + CoreDoFloatOutwards (FloatOutSw False -- Not lambdas + True) -- Float constants + else CoreDoNothing, + -- nofib/spectral/hartel/wang doubles in speed if you + -- do full laziness late in the day. It only happens + -- after fusion and other stuff, so the early pass doesn't + -- catch it. For the record, the redex is + -- f_el22 (f_el21 r_midblock) + + + -- We want CSE to follow the final full-laziness pass, because it may + -- succeed in commoning up things floated out by full laziness. + -- CSE used to rely on the no-shadowing invariant, but it doesn't any more + + if cse then CoreCSE else CoreDoNothing, + + CoreDoFloatInwards, + +-- Case-liberation for -O2. This should be after +-- strictness analysis and the simplification which follows it. + + case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing }, + + if opt_level >= 2 then + CoreLiberateCase + else + CoreDoNothing, + if opt_level >= 2 then + CoreDoSpecConstr + else + CoreDoNothing, + + -- Final clean-up simplification: + CoreDoSimplify (SimplPhase 0) [ + MaxSimplifierIterations max_iter + ] + ] + +-- ----------------------------------------------------------------------------- +-- StgToDo: abstraction of stg-to-stg passes to run. + +data StgToDo + = StgDoMassageForProfiling -- should be (next to) last + -- There's also setStgVarInfo, but its absolute "lastness" + -- is so critical that it is hardwired in (no flag). + | D_stg_stats + +getStgToDo :: DynFlags -> [StgToDo] +getStgToDo dflags + | Just todo <- stgToDo dflags = todo -- set explicitly by user + | otherwise = todo2 + where + stg_stats = dopt Opt_StgStats dflags + + todo1 = if stg_stats then [D_stg_stats] else [] + + todo2 | WayProf `elem` wayNames dflags + = StgDoMassageForProfiling : todo1 + | otherwise + = todo1 + +-- ----------------------------------------------------------------------------- +-- DynFlags parser + +dynamic_flags :: [(String, OptKind DynP)] +dynamic_flags = [ + ( "n" , NoArg (setDynFlag Opt_DryRun) ) + , ( "cpp" , NoArg (setDynFlag Opt_Cpp)) + , ( "F" , NoArg (setDynFlag Opt_Pp)) + , ( "#include" , HasArg (addCmdlineHCInclude) ) + , ( "v" , OptPrefix (setVerbosity) ) + + ------- Specific phases -------------------------------------------- + , ( "pgmL" , HasArg (upd . setPgmL) ) + , ( "pgmP" , HasArg (upd . setPgmP) ) + , ( "pgmF" , HasArg (upd . setPgmF) ) + , ( "pgmc" , HasArg (upd . setPgmc) ) + , ( "pgmm" , HasArg (upd . setPgmm) ) + , ( "pgms" , HasArg (upd . setPgms) ) + , ( "pgma" , HasArg (upd . setPgma) ) + , ( "pgml" , HasArg (upd . setPgml) ) + , ( "pgmdll" , HasArg (upd . setPgmdll) ) + + , ( "optL" , HasArg (upd . addOptL) ) + , ( "optP" , HasArg (upd . addOptP) ) + , ( "optF" , HasArg (upd . addOptF) ) + , ( "optc" , HasArg (upd . addOptc) ) + , ( "optm" , HasArg (upd . addOptm) ) + , ( "opta" , HasArg (upd . addOpta) ) + , ( "optl" , HasArg (upd . addOptl) ) + , ( "optdll" , HasArg (upd . addOptdll) ) + , ( "optdep" , HasArg (upd . addOptdep) ) + + -------- Linking ---------------------------------------------------- + , ( "c" , NoArg (upd $ \d -> d{ ghcLink=NoLink } )) + , ( "no-link" , NoArg (upd $ \d -> d{ ghcLink=NoLink } )) -- Dep. + , ( "-mk-dll" , NoArg (upd $ \d -> d{ ghcLink=MkDLL } )) + + ------- Libraries --------------------------------------------------- + , ( "L" , Prefix addLibraryPath ) + , ( "l" , AnySuffix (\s -> do upd (addOptl s) + upd (addOptdll s))) + + ------- Frameworks -------------------------------------------------- + -- -framework-path should really be -F ... + , ( "framework-path" , HasArg addFrameworkPath ) + , ( "framework" , HasArg (upd . addCmdlineFramework) ) + + ------- Output Redirection ------------------------------------------ + , ( "odir" , HasArg (upd . setOutputDir . Just)) + , ( "o" , SepArg (upd . setOutputFile . Just)) + , ( "ohi" , HasArg (upd . setOutputHi . Just )) + , ( "osuf" , HasArg (upd . setObjectSuf)) + , ( "hcsuf" , HasArg (upd . setHcSuf)) + , ( "hisuf" , HasArg (upd . setHiSuf)) + , ( "hidir" , HasArg (upd . setHiDir . Just)) + , ( "tmpdir" , HasArg (upd . setTmpDir)) + + ------- Keeping temporary files ------------------------------------- + , ( "keep-hc-file" , AnySuffix (\_ -> setDynFlag Opt_KeepHcFiles)) + , ( "keep-s-file" , AnySuffix (\_ -> setDynFlag Opt_KeepSFiles)) + , ( "keep-raw-s-file", AnySuffix (\_ -> setDynFlag Opt_KeepRawSFiles)) + , ( "keep-tmp-files" , AnySuffix (\_ -> setDynFlag Opt_KeepTmpFiles)) + + ------- Miscellaneous ---------------------------------------------- + , ( "no-hs-main" , NoArg (setDynFlag Opt_NoHsMain)) + , ( "main-is" , SepArg setMainIs ) + + ------- recompilation checker -------------------------------------- + , ( "recomp" , NoArg (setDynFlag Opt_RecompChecking) ) + , ( "no-recomp" , NoArg (unSetDynFlag Opt_RecompChecking) ) + + ------- Packages ---------------------------------------------------- + , ( "package-conf" , HasArg extraPkgConf_ ) + , ( "no-user-package-conf", NoArg (unSetDynFlag Opt_ReadUserPackageConf) ) + , ( "package-name" , HasArg ignorePackage ) -- for compatibility + , ( "package" , HasArg exposePackage ) + , ( "hide-package" , HasArg hidePackage ) + , ( "ignore-package" , HasArg ignorePackage ) + , ( "syslib" , HasArg exposePackage ) -- for compatibility + + ------ HsCpp opts --------------------------------------------------- + , ( "D", AnySuffix (upd . addOptP) ) + , ( "U", AnySuffix (upd . addOptP) ) + + ------- Include/Import Paths ---------------------------------------- + , ( "I" , Prefix addIncludePath) + , ( "i" , OptPrefix addImportPath ) + + ------ Debugging ---------------------------------------------------- + , ( "dstg-stats", NoArg (setDynFlag Opt_StgStats)) + + , ( "ddump-cmm", setDumpFlag Opt_D_dump_cmm) + , ( "ddump-asm", setDumpFlag Opt_D_dump_asm) + , ( "ddump-cpranal", setDumpFlag Opt_D_dump_cpranal) + , ( "ddump-deriv", setDumpFlag Opt_D_dump_deriv) + , ( "ddump-ds", setDumpFlag Opt_D_dump_ds) + , ( "ddump-flatC", setDumpFlag Opt_D_dump_flatC) + , ( "ddump-foreign", setDumpFlag Opt_D_dump_foreign) + , ( "ddump-inlinings", setDumpFlag Opt_D_dump_inlinings) + , ( "ddump-occur-anal", setDumpFlag Opt_D_dump_occur_anal) + , ( "ddump-parsed", setDumpFlag Opt_D_dump_parsed) + , ( "ddump-rn", setDumpFlag Opt_D_dump_rn) + , ( "ddump-simpl", setDumpFlag Opt_D_dump_simpl) + , ( "ddump-simpl-iterations", setDumpFlag Opt_D_dump_simpl_iterations) + , ( "ddump-spec", setDumpFlag Opt_D_dump_spec) + , ( "ddump-prep", setDumpFlag Opt_D_dump_prep) + , ( "ddump-stg", setDumpFlag Opt_D_dump_stg) + , ( "ddump-stranal", setDumpFlag Opt_D_dump_stranal) + , ( "ddump-tc", setDumpFlag Opt_D_dump_tc) + , ( "ddump-types", setDumpFlag Opt_D_dump_types) + , ( "ddump-rules", setDumpFlag Opt_D_dump_rules) + , ( "ddump-cse", setDumpFlag Opt_D_dump_cse) + , ( "ddump-worker-wrapper", setDumpFlag Opt_D_dump_worker_wrapper) + , ( "ddump-rn-trace", NoArg (setDynFlag Opt_D_dump_rn_trace)) + , ( "ddump-if-trace", NoArg (setDynFlag Opt_D_dump_if_trace)) + , ( "ddump-tc-trace", setDumpFlag Opt_D_dump_tc_trace) + , ( "ddump-splices", setDumpFlag Opt_D_dump_splices) + , ( "ddump-rn-stats", NoArg (setDynFlag Opt_D_dump_rn_stats)) + , ( "ddump-opt-cmm", setDumpFlag Opt_D_dump_opt_cmm) + , ( "ddump-simpl-stats", setDumpFlag Opt_D_dump_simpl_stats) + , ( "ddump-bcos", setDumpFlag Opt_D_dump_BCOs) + , ( "dsource-stats", setDumpFlag Opt_D_source_stats) + , ( "dverbose-core2core", setDumpFlag Opt_D_verbose_core2core) + , ( "dverbose-stg2stg", setDumpFlag Opt_D_verbose_stg2stg) + , ( "ddump-hi-diffs", setDumpFlag Opt_D_dump_hi_diffs) + , ( "ddump-hi", setDumpFlag Opt_D_dump_hi) + , ( "ddump-minimal-imports", setDumpFlag Opt_D_dump_minimal_imports) + , ( "ddump-vect", setDumpFlag Opt_D_dump_vect) + , ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting)) + , ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting)) + , ( "dcmm-lint", NoArg (setDynFlag Opt_DoCmmLinting)) + , ( "dshow-passes", NoArg (do unSetDynFlag Opt_RecompChecking + setVerbosity "2") ) + + ------ Machine dependant (-m) stuff --------------------------- + + , ( "monly-2-regs", NoArg (upd (\s -> s{stolen_x86_regs = 2}) )) + , ( "monly-3-regs", NoArg (upd (\s -> s{stolen_x86_regs = 3}) )) + , ( "monly-4-regs", NoArg (upd (\s -> s{stolen_x86_regs = 4}) )) + + ------ Warning opts ------------------------------------------------- + , ( "W" , NoArg (mapM_ setDynFlag minusWOpts) ) + , ( "Werror" , NoArg (setDynFlag Opt_WarnIsError) ) + , ( "Wall" , NoArg (mapM_ setDynFlag minusWallOpts) ) + , ( "Wnot" , NoArg (mapM_ unSetDynFlag minusWallOpts) ) /* DEPREC */ + , ( "w" , NoArg (mapM_ unSetDynFlag minusWallOpts) ) + + ------ Optimisation flags ------------------------------------------ + , ( "O" , NoArg (upd (setOptLevel 1))) + , ( "Onot" , NoArg (upd (setOptLevel 0))) + , ( "O" , PrefixPred (all isDigit) + (\f -> upd (setOptLevel (read f)))) + + , ( "fmax-simplifier-iterations", + PrefixPred (all isDigit) + (\n -> upd (\dfs -> + dfs{ maxSimplIterations = read n })) ) + + , ( "frule-check", + SepArg (\s -> upd (\dfs -> dfs{ ruleCheck = Just s }))) + + ------ Compiler flags ----------------------------------------------- + + , ( "fasm", AnySuffix (\_ -> setTarget HscAsm) ) + , ( "fvia-c", NoArg (setTarget HscC) ) + , ( "fvia-C", NoArg (setTarget HscC) ) + , ( "filx", NoArg (setTarget HscILX) ) + + , ( "fglasgow-exts", NoArg (mapM_ setDynFlag glasgowExtsFlags) ) + , ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) ) + + -- the rest of the -f* and -fno-* flags + , ( "fno-", PrefixPred (\f -> isFFlag f) (\f -> unSetDynFlag (getFFlag f)) ) + , ( "f", PrefixPred (\f -> isFFlag f) (\f -> setDynFlag (getFFlag f)) ) + ] + +-- these -f flags can all be reversed with -fno- + +fFlags = [ + ( "warn-duplicate-exports", Opt_WarnDuplicateExports ), + ( "warn-hi-shadowing", Opt_WarnHiShadows ), + ( "warn-incomplete-patterns", Opt_WarnIncompletePatterns ), + ( "warn-incomplete-record-updates", Opt_WarnIncompletePatternsRecUpd ), + ( "warn-missing-fields", Opt_WarnMissingFields ), + ( "warn-missing-methods", Opt_WarnMissingMethods ), + ( "warn-missing-signatures", Opt_WarnMissingSigs ), + ( "warn-name-shadowing", Opt_WarnNameShadowing ), + ( "warn-overlapping-patterns", Opt_WarnOverlappingPatterns ), + ( "warn-simple-patterns", Opt_WarnSimplePatterns ), + ( "warn-type-defaults", Opt_WarnTypeDefaults ), + ( "warn-unused-binds", Opt_WarnUnusedBinds ), + ( "warn-unused-imports", Opt_WarnUnusedImports ), + ( "warn-unused-matches", Opt_WarnUnusedMatches ), + ( "warn-deprecations", Opt_WarnDeprecations ), + ( "warn-orphans", Opt_WarnOrphans ), + ( "fi", Opt_FFI ), -- support `-ffi'... + ( "ffi", Opt_FFI ), -- ...and also `-fffi' + ( "arrows", Opt_Arrows ), -- arrow syntax + ( "parr", Opt_PArr ), + ( "th", Opt_TH ), + ( "implicit-prelude", Opt_ImplicitPrelude ), + ( "scoped-type-variables", Opt_ScopedTypeVariables ), + ( "monomorphism-restriction", Opt_MonomorphismRestriction ), + ( "implicit-params", Opt_ImplicitParams ), + ( "allow-overlapping-instances", Opt_AllowOverlappingInstances ), + ( "allow-undecidable-instances", Opt_AllowUndecidableInstances ), + ( "allow-incoherent-instances", Opt_AllowIncoherentInstances ), + ( "generics", Opt_Generics ), + ( "strictness", Opt_Strictness ), + ( "full-laziness", Opt_FullLaziness ), + ( "cse", Opt_CSE ), + ( "ignore-interface-pragmas", Opt_IgnoreInterfacePragmas ), + ( "omit-interface-pragmas", Opt_OmitInterfacePragmas ), + ( "do-lambda-eta-expansion", Opt_DoLambdaEtaExpansion ), + ( "ignore-asserts", Opt_IgnoreAsserts ), + ( "do-eta-reduction", Opt_DoEtaReduction ), + ( "case-merge", Opt_CaseMerge ), + ( "unbox-strict-fields", Opt_UnboxStrictFields ), + ( "excess-precision", Opt_ExcessPrecision ), + ( "asm-mangling", Opt_DoAsmMangling ) + ] + +glasgowExtsFlags = [ + Opt_GlasgowExts, + Opt_FFI, + Opt_TH, + Opt_ImplicitParams, + Opt_ScopedTypeVariables ] + +isFFlag f = f `elem` (map fst fFlags) +getFFlag f = fromJust (lookup f fFlags) + +-- ----------------------------------------------------------------------------- +-- Parsing the dynamic flags. + +parseDynamicFlags :: DynFlags -> [String] -> IO (DynFlags,[String]) +parseDynamicFlags dflags args = do + let ((leftover,errs),dflags') + = runCmdLine (processArgs dynamic_flags args) dflags + when (not (null errs)) $ do + throwDyn (UsageError (unlines errs)) + return (dflags', leftover) + + +type DynP = CmdLineP DynFlags + +upd :: (DynFlags -> DynFlags) -> DynP () +upd f = do + dfs <- getCmdLineState + putCmdLineState $! (f dfs) + +setDynFlag, unSetDynFlag :: DynFlag -> DynP () +setDynFlag f = upd (\dfs -> dopt_set dfs f) +unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) + +setDumpFlag :: DynFlag -> OptKind DynP +setDumpFlag dump_flag + = NoArg (unSetDynFlag Opt_RecompChecking >> setDynFlag dump_flag) + -- Whenver we -ddump, switch off the recompilation checker, + -- else you don't see the dump! + +setVerbosity "" = upd (\dfs -> dfs{ verbosity = 3 }) +setVerbosity n + | all isDigit n = upd (\dfs -> dfs{ verbosity = read n }) + | otherwise = throwDyn (UsageError "can't parse verbosity flag (-v)") + +addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s}) + +extraPkgConf_ p = upd (\s -> s{ extraPkgConfs = p : extraPkgConfs s }) + +exposePackage p = + upd (\s -> s{ packageFlags = ExposePackage p : packageFlags s }) +hidePackage p = + upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) +ignorePackage p = + upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s }) + +-- we can only switch between HscC, HscAsmm, and HscILX with dynamic flags +-- (-fvia-C, -fasm, -filx respectively). +setTarget l = upd (\dfs -> case hscTarget dfs of + HscC -> dfs{ hscTarget = l } + HscAsm -> dfs{ hscTarget = l } + HscILX -> dfs{ hscTarget = l } + _ -> dfs) + +setOptLevel :: Int -> DynFlags -> 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" + | otherwise + = updOptLevel n dflags + + +setMainIs :: String -> DynP () +setMainIs arg + | not (null main_mod) -- The arg looked like "Foo.baz" + = upd $ \d -> d{ mainFunIs = Just main_fn, + mainModIs = Just main_mod } + + | isUpper (head main_fn) -- The arg looked like "Foo" + = upd $ \d -> d{ mainModIs = Just main_fn } + + | otherwise -- The arg looked like "baz" + = upd $ \d -> d{ mainFunIs = Just main_fn } + where + (main_mod, main_fn) = splitLongestPrefix arg (== '.') + + +----------------------------------------------------------------------------- +-- Paths & Libraries + +-- -i on its own deletes the import paths +addImportPath "" = upd (\s -> s{importPaths = []}) +addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p}) + + +addLibraryPath p = + upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p}) + +addIncludePath p = + upd (\s -> s{includePaths = includePaths s ++ splitPathList p}) + +addFrameworkPath p = + upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p}) + +split_marker = ':' -- not configurable (ToDo) + +splitPathList :: String -> [String] +splitPathList s = filter notNull (splitUp s) + -- empty paths are ignored: there might be a trailing + -- ':' in the initial list, for example. Empty paths can + -- cause confusion when they are translated into -I options + -- for passing to gcc. + where +#ifndef mingw32_TARGET_OS + splitUp xs = split split_marker xs +#else + -- Windows: 'hybrid' support for DOS-style paths in directory lists. + -- + -- That is, if "foo:bar:baz" is used, this interpreted as + -- consisting of three entries, 'foo', 'bar', 'baz'. + -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted + -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar" + -- + -- Notice that no attempt is made to fully replace the 'standard' + -- split marker ':' with the Windows / DOS one, ';'. The reason being + -- that this will cause too much breakage for users & ':' will + -- work fine even with DOS paths, if you're not insisting on being silly. + -- So, use either. + splitUp [] = [] + splitUp (x:':':div:xs) + | div `elem` dir_markers = do + let (p,rs) = findNextPath xs + in ((x:':':div:p): splitUp rs) + -- we used to check for existence of the path here, but that + -- required the IO monad to be threaded through the command-line + -- parser which is quite inconvenient. The + splitUp xs = do + let (p,rs) = findNextPath xs + return (cons p (splitUp rs)) + + cons "" xs = xs + cons x xs = x:xs + + -- will be called either when we've consumed nought or the + -- ":/" part of a DOS path, so splitting is just a Q of + -- finding the next split marker. + findNextPath xs = + case break (`elem` split_markers) xs of + (p, d:ds) -> (p, ds) + (p, xs) -> (p, xs) + + split_markers :: [Char] + split_markers = [':', ';'] + + dir_markers :: [Char] + dir_markers = ['/', '\\'] +#endif + + +----------------------------------------------------------------------------- +-- Via-C compilation stuff + +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 + sta = opt_Static + in + ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" +-- , if suffixMatch "mingw32" cTARGETPLATFORM then "-mno-cygwin" else "" + ], + [ "-fno-defer-pop", +#ifdef HAVE_GCC_MNO_OMIT_LFPTR + -- Some gccs are configured with + -- -momit-leaf-frame-pointer on by default, and it + -- apparently takes precedence over + -- -fomit-frame-pointer, so we disable it first here. + "-mno-omit-leaf-frame-pointer", +#endif + "-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"] ) + +#elif mips_TARGET_ARCH + = ( ["-static"], [] ) + +#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 + -- Apple prefers to do things the other way round. + -- PIC is on by default. + -- -mdynamic-no-pic: + -- Turn off PIC code generation. + -- -fno-common: + -- Don't generate "common" symbols - these are unwanted + -- in dynamic libraries. + + | opt_PIC + = ["-fno-common"] + | otherwise + = ["-mdynamic-no-pic"] +#elif mingw32_TARGET_OS + -- no -fPIC for Windows + = [] +#else + | opt_PIC + = ["-fPIC"] + | otherwise + = [] +#endif diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index 7b7dcf8..434b7d7 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -34,7 +34,8 @@ import Util ( sortLe, global ) import Outputable import qualified Pretty import SrcLoc ( srcSpanStart ) -import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt, opt_ErrorSpans ) +import DynFlags ( DynFlags(..), DynFlag(..), dopt ) +import StaticFlags ( opt_ErrorSpans ) import System ( ExitCode(..), exitWith ) import DATA_IOREF import IO ( hPutStrLn, stderr ) diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index a260f3e..97904a1 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -24,11 +24,9 @@ import Module import UniqFM ( filterUFM ) import HscTypes ( Linkable(..), Unlinked(..) ) import Packages -import DriverState -import DriverUtil import FastString import Util -import CmdLineOpts ( DynFlags(..) ) +import DynFlags ( DynFlags(..), isOneShot, GhcMode(..) ) import Outputable import DATA_IOREF ( IORef, writeIORef, readIORef ) @@ -50,7 +48,7 @@ type BaseName = String -- Basename of file -- The Finder provides a thin filesystem abstraction to the rest of -- the compiler. For a given module, it can tell you where the -- source, interface, and object files for that module live. --- + -- It does *not* know which particular package a module lives in. Use -- Packages.moduleToPackageConfig for that. @@ -174,26 +172,23 @@ findModule' dflags name = do findHomeModule' :: DynFlags -> Module -> IO LocalFindResult findHomeModule' dflags mod = do let home_path = importPaths dflags - hisuf <- readIORef v_Hi_suf - mode <- readIORef v_GhcMode + hisuf = hiSuf dflags let source_exts = - [ ("hs", mkHomeModLocationSearched mod "hs") - , ("lhs", mkHomeModLocationSearched mod "lhs") + [ ("hs", mkHomeModLocationSearched dflags mod "hs") + , ("lhs", mkHomeModLocationSearched dflags mod "lhs") ] - hi_exts = [ (hisuf, mkHiOnlyModLocation hisuf) - , (addBootSuffix hisuf, mkHiOnlyModLocation hisuf) + hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf) + , (addBootSuffix hisuf, mkHiOnlyModLocation dflags hisuf) ] -- In compilation manager modes, we look for source files in the home -- package because we can compile these automatically. In one-shot -- compilation mode we look for .hi and .hi-boot files only. - exts - | DoMkDependHS <- mode = source_exts - | isCompManagerMode mode = source_exts - | otherwise {-one-shot-} = hi_exts + exts | isOneShot (ghcMode dflags) = hi_exts + | otherwise = source_exts searchPathExts home_path mod exts @@ -201,31 +196,31 @@ findPackageModule' :: DynFlags -> Module -> IO LocalFindResult findPackageModule' dflags mod = case moduleToPackageConfig dflags mod of Nothing -> return (Failed []) - Just pkg_info -> findPackageIface mod pkg_info + Just pkg_info -> findPackageIface dflags mod pkg_info -findPackageIface :: Module -> (PackageConfig,Bool) -> IO LocalFindResult -findPackageIface mod pkg_info@(pkg_conf, _) = do - mode <- readIORef v_GhcMode - tag <- readIORef v_Build_tag +findPackageIface :: DynFlags -> Module -> (PackageConfig,Bool) -> IO LocalFindResult +findPackageIface dflags mod pkg_info@(pkg_conf, _) = do let + tag = buildTag dflags + -- hi-suffix for packages depends on the build tag. package_hisuf | null tag = "hi" | otherwise = tag ++ "_hi" hi_exts = [ (package_hisuf, - mkPackageModLocation pkg_info package_hisuf) ] + mkPackageModLocation dflags pkg_info package_hisuf) ] source_exts = - [ ("hs", mkPackageModLocation pkg_info package_hisuf) - , ("lhs", mkPackageModLocation pkg_info package_hisuf) + [ ("hs", mkPackageModLocation dflags pkg_info package_hisuf) + , ("lhs", mkPackageModLocation dflags pkg_info package_hisuf) ] -- mkdependHS needs to look for source files in packages too, so -- that we can make dependencies between package before they have -- been built. exts - | DoMkDependHS <- mode = hi_exts ++ source_exts - | otherwise = hi_exts + | MkDepend <- ghcMode dflags = hi_exts ++ source_exts + | otherwise = hi_exts -- we never look for a .hi-boot file in an external package; -- .hi-boot files only make sense for the home package. @@ -275,21 +270,22 @@ searchPathExts paths mod exts then do { res <- mk_result; return (Succeeded res) } else search rest -mkHomeModLocationSearched :: Module -> FileExt +mkHomeModLocationSearched :: DynFlags -> Module -> FileExt -> FilePath -> BaseName -> IO FinderCacheEntry -mkHomeModLocationSearched mod suff path basename = do - loc <- mkHomeModLocation2 mod (path ++ '/':basename) suff +mkHomeModLocationSearched dflags mod suff path basename = do + loc <- mkHomeModLocation2 dflags mod (path ++ '/':basename) suff return (loc, Nothing) -mkHiOnlyModLocation :: FileExt -> FilePath -> BaseName -> IO FinderCacheEntry -mkHiOnlyModLocation hisuf path basename = do - loc <- hiOnlyModLocation path basename hisuf +mkHiOnlyModLocation :: DynFlags -> FileExt -> FilePath -> BaseName + -> IO FinderCacheEntry +mkHiOnlyModLocation dflags hisuf path basename = do + loc <- hiOnlyModLocation dflags path basename hisuf return (loc, Nothing) -mkPackageModLocation :: (PackageConfig, Bool) -> FileExt +mkPackageModLocation :: DynFlags -> (PackageConfig, Bool) -> FileExt -> FilePath -> BaseName -> IO FinderCacheEntry -mkPackageModLocation pkg_info hisuf path basename = do - loc <- hiOnlyModLocation path basename hisuf +mkPackageModLocation dflags pkg_info hisuf path basename = do + loc <- hiOnlyModLocation dflags path basename hisuf return (loc, Just pkg_info) -- ----------------------------------------------------------------------------- @@ -325,29 +321,30 @@ mkPackageModLocation pkg_info hisuf path basename = do -- ext -- The filename extension of the source file (usually "hs" or "lhs"). -mkHomeModLocation :: Module -> FilePath -> IO ModLocation -mkHomeModLocation mod src_filename = do +mkHomeModLocation :: DynFlags -> Module -> FilePath -> IO ModLocation +mkHomeModLocation dflags mod src_filename = do let (basename,extension) = splitFilename src_filename - mkHomeModLocation2 mod basename extension + mkHomeModLocation2 dflags mod basename extension -mkHomeModLocation2 :: Module +mkHomeModLocation2 :: DynFlags + -> Module -> FilePath -- Of source module, without suffix -> String -- Suffix -> IO ModLocation -mkHomeModLocation2 mod src_basename ext = do +mkHomeModLocation2 dflags mod src_basename ext = do let mod_basename = dots_to_slashes (moduleUserString mod) - obj_fn <- mkObjPath src_basename mod_basename - hi_fn <- mkHiPath src_basename mod_basename + obj_fn <- mkObjPath dflags src_basename mod_basename + hi_fn <- mkHiPath dflags src_basename mod_basename return (ModLocation{ ml_hs_file = Just (src_basename ++ '.':ext), ml_hi_file = hi_fn, ml_obj_file = obj_fn }) -hiOnlyModLocation :: FilePath -> String -> Suffix -> IO ModLocation -hiOnlyModLocation path basename hisuf +hiOnlyModLocation :: DynFlags -> FilePath -> String -> Suffix -> IO ModLocation +hiOnlyModLocation dflags path basename hisuf = do let full_basename = path++'/':basename - obj_fn <- mkObjPath full_basename basename + obj_fn <- mkObjPath dflags full_basename basename return ModLocation{ ml_hs_file = Nothing, ml_hi_file = full_basename ++ '.':hisuf, -- Remove the .hi-boot suffix from @@ -360,30 +357,34 @@ hiOnlyModLocation path basename hisuf -- | Constructs the filename of a .o file for a given source file. -- Does /not/ check whether the .o file exists mkObjPath - :: FilePath -- the filename of the source file, minus the extension + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension -> String -- the module name with dots replaced by slashes -> IO FilePath -mkObjPath basename mod_basename - = do odir <- readIORef v_Output_dir - osuf <- readIORef v_Object_suf - - let obj_basename | Just dir <- odir = dir ++ '/':mod_basename - | otherwise = basename +mkObjPath dflags basename mod_basename + = do let + odir = outputDir dflags + osuf = objectSuf dflags + + obj_basename | Just dir <- odir = dir ++ '/':mod_basename + | otherwise = basename return (obj_basename ++ '.':osuf) -- | Constructs the filename of a .hi file for a given source file. -- Does /not/ check whether the .hi file exists mkHiPath - :: FilePath -- the filename of the source file, minus the extension + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension -> String -- the module name with dots replaced by slashes -> IO FilePath -mkHiPath basename mod_basename - = do hidir <- readIORef v_Hi_dir - hisuf <- readIORef v_Hi_suf +mkHiPath dflags basename mod_basename + = do let + hidir = hiDir dflags + hisuf = hiSuf dflags - let hi_basename | Just dir <- hidir = dir ++ '/':mod_basename - | otherwise = basename + hi_basename | Just dir <- hidir = dir ++ '/':mod_basename + | otherwise = basename return (hi_basename ++ '.':hisuf) diff --git a/ghc/compiler/main/GetImports.hs b/ghc/compiler/main/GetImports.hs index 6c9f9ef..c165b4a 100644 --- a/ghc/compiler/main/GetImports.hs +++ b/ghc/compiler/main/GetImports.hs @@ -19,7 +19,7 @@ import PrelNames ( gHC_PRIM ) import StringBuffer ( StringBuffer, hGetStringBuffer ) import SrcLoc ( Located(..), mkSrcLoc, unLoc ) import FastString ( mkFastString ) -import CmdLineOpts ( DynFlags ) +import DynFlags ( DynFlags ) import ErrUtils import Pretty import Panic diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 81015ac..8570044 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -69,7 +69,7 @@ import CodeGen ( codeGen ) import CmmParse ( parseCmmFile ) import CodeOutput ( codeOutput ) -import CmdLineOpts +import DynFlags import DriverPhases ( HscSource(..) ) import ErrUtils import UniqSupply ( mkSplitUniqSupply ) @@ -99,13 +99,12 @@ import DATA_IOREF ( newIORef, readIORef ) %************************************************************************ \begin{code} -newHscEnv :: GhciMode -> DynFlags -> IO HscEnv -newHscEnv ghci_mode dflags +newHscEnv :: DynFlags -> IO HscEnv +newHscEnv dflags = do { eps_var <- newIORef initExternalPackageState ; us <- mkSplitUniqSupply 'r' ; nc_var <- newIORef (initNameCache us knownKeyNames) - ; return (HscEnv { hsc_mode = ghci_mode, - hsc_dflags = dflags, + ; return (HscEnv { hsc_dflags = dflags, hsc_HPT = emptyHomePackageTable, hsc_EPS = eps_var, hsc_NC = nc_var } ) } @@ -183,7 +182,7 @@ hscMain hsc_env msg_act mod_summary -- hscNoRecomp definitely expects to have the old interface available hscNoRecomp hsc_env msg_act mod_summary have_object (Just old_iface) - | isOneShot (hsc_mode hsc_env) + | isOneShot (ghcMode (hsc_dflags hsc_env)) = do { compilationProgressMsg (hsc_dflags hsc_env) $ "compilation IS NOT required"; @@ -241,9 +240,9 @@ hscFileFrontEnd hsc_env msg_act mod_summary = do { ------------------- -- DISPLAY PROGRESS MESSAGE ------------------- - let one_shot = isOneShot (hsc_mode hsc_env) + let one_shot = isOneShot (ghcMode (hsc_dflags hsc_env)) ; let dflags = hsc_dflags hsc_env - ; let toInterp = dopt_HscTarget dflags == HscInterpreted + ; let toInterp = hscTarget dflags == HscInterpreted ; when (not one_shot) $ compilationProgressMsg dflags $ ("Compiling " ++ showModMsg (not toInterp) mod_summary) @@ -316,7 +315,7 @@ hscBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result) = do { -- OMITTED: -- ; seqList imported_modules (return ()) - let one_shot = isOneShot (hsc_mode hsc_env) + let one_shot = isOneShot (ghcMode (hsc_dflags hsc_env)) dflags = hsc_dflags hsc_env ------------------- @@ -464,7 +463,7 @@ hscCodeGen dflags prepd_binds <- _scc_ "CorePrep" corePrepPgm dflags core_binds type_env; - case dopt_HscTarget dflags of + case hscTarget dflags of HscNothing -> return (False, False, Nothing) HscInterpreted -> diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 5119a78..dd4f003 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -6,7 +6,6 @@ \begin{code} module HscTypes ( HscEnv(..), hscEPS, - GhciMode(..), isOneShot, ModDetails(..), ModGuts(..), ModImports(..), ForeignStubs(..), @@ -85,7 +84,7 @@ import Class ( Class, classSelIds, classTyCon ) import TyCon ( TyCon, tyConSelIds, tyConDataCons ) import DataCon ( dataConImplicitIds ) import Packages ( PackageIdH, PackageId ) -import CmdLineOpts ( DynFlags ) +import DynFlags ( DynFlags(..), isOneShot ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString ) import BasicTypes ( Version, initialVersion, IPName, Fixity, defaultFixity, DeprecTxt ) @@ -116,8 +115,7 @@ The HscEnv gives the environment in which to compile a chunk of code. \begin{code} data HscEnv - = HscEnv { hsc_mode :: GhciMode, - hsc_dflags :: DynFlags, + = HscEnv { hsc_dflags :: DynFlags, hsc_HPT :: HomePackageTable, -- The home package table describes already-compiled @@ -146,20 +144,6 @@ hscEPS :: HscEnv -> IO ExternalPackageState hscEPS hsc_env = readIORef (hsc_EPS hsc_env) \end{code} -The GhciMode is self-explanatory: - -\begin{code} -data GhciMode = Batch -- ghc --make Main - | Interactive -- ghc --interactive - | OneShot -- ghc Foo.hs - | IDE -- Visual Studio etc - deriving Eq - -isOneShot :: GhciMode -> Bool -isOneShot OneShot = True -isOneShot _other = False -\end{code} - \begin{code} type HomePackageTable = ModuleEnv HomeModInfo -- Domain = modules in the home package type PackageIfaceTable = ModuleEnv ModIface -- Domain = modules in the imported packages @@ -208,7 +192,7 @@ hptRules :: HscEnv -> [(Module, IsBootInterface)] -> [IdCoreRule] -- Get rules from modules "below" this one (in the dependency sense) -- C.f Inst.hptInstances hptRules hsc_env deps - | isOneShot (hsc_mode hsc_env) = [] + | isOneShot (ghcMode (hsc_dflags hsc_env)) = [] | otherwise = let hpt = hsc_HPT hsc_env diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index bb128f2..f311130 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,11 +1,9 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} - ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.148 2005/02/10 15:26:23 simonmar Exp $ -- -- GHC Driver program -- --- (c) The University of Glasgow 2002 +-- (c) The University of Glasgow 2005 -- ----------------------------------------------------------------------------- @@ -18,40 +16,30 @@ import InteractiveUI ( ghciWelcomeMsg, interactiveUI ) #endif -import DriverState ( isInteractiveMode ) +import MkIface ( showIface ) import CompManager ( cmInit, cmLoadModules, cmDepAnal ) -import HscTypes ( GhciMode(..) ) -import Config ( cBooterVersion, cGhcUnregisterised, cProjectVersion ) -import SysTools ( initSysTools, cleanTempFiles, normalisePath ) -import Packages ( dumpPackages, initPackages, haskell98PackageId, PackageIdH(..) ) -import DriverPipeline ( staticLink, doMkDLL, compileFile ) -import DriverState ( isLinkMode, - isCompManagerMode, isInterpretiveMode, - buildStgToDo, findBuildTag, unregFlags, - v_GhcMode, GhcMode(..), - v_Keep_tmp_files, v_Ld_inputs, v_Ways, - v_Output_file, v_Output_hi, v_GhcLink, - verifyOutputFiles, GhcLink(..) - ) -import DriverFlags +import Config +import SysTools +import Packages ( dumpPackages, initPackages, haskell98PackageId, + PackageIdH(..) ) +import DriverPipeline ( runPipeline, staticLink, doMkDLL ) import DriverMkDepend ( doMkDependHS ) -import DriverPhases ( Phase, isStopLn, isSourceFilename ) +import DriverPhases ( Phase(..), isStopLn, isSourceFilename, anyHsc ) -import DriverUtil ( add, handle, handleDyn, later, unknownFlagsErr ) -import CmdLineOpts ( DynFlags(..), HscTarget(..), v_Static_hsc_opts, - defaultDynFlags ) +import DynFlags +import StaticFlags ( parseStaticFlags, staticFlags, v_Ld_inputs ) +import CmdLineParser import BasicTypes ( failed ) -import Outputable import Util -import Panic ( GhcException(..), panic, installSignalHandlers ) +import Panic -import DATA_IOREF ( readIORef, writeIORef ) +-- Standard Haskell libraries import EXCEPTION ( throwDyn, Exception(..), AsyncException(StackOverflow) ) --- Standard Haskell libraries import IO +import Directory ( doesFileExist, doesDirectoryExist ) import System ( getArgs, exitWith, ExitCode(..) ) import Monad import List @@ -60,27 +48,19 @@ import Maybe ----------------------------------------------------------------------------- -- ToDo: --- new mkdependHS doesn't support all the options that the old one did (-X et al.) -- time commands when run with -v --- split marker --- java generation -- user ways -- Win32 support: proper signal handling --- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too -- reading the package configuration file is too slow -- -K ----------------------------------------------------------------------------- --- Differences vs. old driver: - --- No more "Enter your Haskell program, end with ^D (on a line of its own):" --- consistency checking removed (may do this properly later) --- no -Ofile - ------------------------------------------------------------------------------ -- Main loop main = + --------------------------------------- + -- exception handlers + -- top-level exception handler: any unrecognised exception is a compiler bug. handle (\exception -> do hFlush stdout @@ -105,76 +85,65 @@ main = installSignalHandlers - argv <- getArgs - let (minusB_args, argv') = partition (prefixMatch "-B") argv - top_dir <- initSysTools minusB_args - - -- Process all the other arguments, and get the source files - non_static <- processStaticFlags argv' - mode <- readIORef v_GhcMode - - -- -O and --interactive are not a good combination - -- ditto with any kind of way selection - orig_ways <- readIORef v_Ways - when (notNull orig_ways && isInterpretiveMode mode) $ - do throwDyn (UsageError - "--interactive can't be used with -prof, -ticky, -unreg or -smp.") + ---------------------------------------- + -- command-line parsing + argv0 <- getArgs - -- Find the build tag, and re-process the build-specific options. - -- Also add in flags for unregisterised compilation, if - -- GhcUnregisterised=YES. - way_opts <- findBuildTag - let unreg_opts | cGhcUnregisterised == "YES" = unregFlags - | otherwise = [] - extra_non_static <- processStaticFlags (unreg_opts ++ way_opts) + -- 1. we grab the -B option if there is one + let (minusB_args, argv1) = partition (prefixMatch "-B") argv0 + dflags0 <- initSysTools minusB_args defaultDynFlags - -- Give the static flags to hsc - static_opts <- buildStaticHscOpts - writeIORef v_Static_hsc_opts static_opts + -- 2. Parse the "mode" flags (--make, --interactive etc.) + (cli_mode, argv2) <- parseModeFlags argv1 - -- build the default DynFlags (these may be adjusted on a per - -- module basis by OPTIONS pragmas and settings in the interpreter). + -- 3. Parse the static flags + argv3 <- parseStaticFlags argv2 - stg_todo <- buildStgToDo + -- 4. Parse the dynamic flags + dflags1 <- initDynFlags dflags0 - -- set the "global" HscTarget. The HscTarget can be further adjusted on a module - -- by module basis, using only the -fvia-C and -fasm flags. If the global - -- HscTarget is not HscC or HscAsm, -fvia-C and -fasm have no effect. - let dflags0 = defaultDynFlags - let lang = case mode of + -- set the default HscTarget. The HscTarget can be further + -- adjusted on a module by module basis, using only the -fvia-C and + -- -fasm flags. If the default HscTarget is not HscC or HscAsm, + -- -fvia-C and -fasm have no effect. + let lang = case cli_mode of DoInteractive -> HscInterpreted DoEval _ -> HscInterpreted - _other -> hscTarget dflags0 + _other -> hscTarget dflags1 + + let mode = case cli_mode of + DoInteractive -> Interactive + DoEval _ -> Interactive + DoMake -> BatchCompile + DoMkDependHS -> MkDepend + _ -> OneShot - let dflags1 = dflags0{ stgToDo = stg_todo, + let dflags2 = dflags1{ ghcMode = mode, hscTarget = lang, -- leave out hscOutName for now hscOutName = panic "Main.main:hscOutName not set", - verbosity = case mode of + verbosity = case cli_mode of DoEval _ -> 0 _other -> 1 } -- The rest of the arguments are "dynamic" -- Leftover ones are presumably files - (dflags2, fileish_args) <- processDynamicFlags - (extra_non_static ++ non_static) dflags1 + (dflags3, fileish_args) <- parseDynamicFlags dflags2 argv3 -- make sure we clean up after ourselves - later (do forget_it <- readIORef v_Keep_tmp_files - unless forget_it $ do - cleanTempFiles dflags2 - ) $ do + later (unless (dopt Opt_KeepTmpFiles dflags3) $ + cleanTempFiles dflags3) $ do -- exceptions will be blocked while we clean the temporary files, -- so there shouldn't be any difficulty if we receive further -- signals. -- Display banner - showBanner mode dflags2 + showBanner cli_mode dflags3 -- Read the package config(s), and process the package-related -- command-line flags - dflags <- initPackages dflags2 + dflags <- initPackages dflags3 let {- @@ -206,75 +175,247 @@ main = -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on -- the command-line. - mapM_ (add v_Ld_inputs) (reverse objs) + mapM_ (consIORef v_Ld_inputs) (reverse objs) ---------------- Display configuration ----------- when (verbosity dflags >= 4) $ dumpPackages dflags - when (verbosity dflags >= 3) $ - hPutStrLn stderr ("Hsc static flags: " ++ unwords static_opts) + when (verbosity dflags >= 3) $ do + hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) ---------------- Final sanity checking ----------- - checkOptions mode srcs objs + checkOptions cli_mode dflags srcs objs ---------------- Do the business ----------- + case cli_mode of + ShowUsage -> showGhcUsage cli_mode + PrintLibdir -> do d <- getTopDir; putStrLn d + ShowVersion -> showVersion + ShowNumVersion -> putStrLn cProjectVersion + ShowInterface f -> showIface f + DoMake -> doMake dflags srcs + DoMkDependHS -> doMkDependHS dflags srcs + StopBefore p -> oneShot dflags p srcs + DoInteractive -> interactiveUI dflags srcs Nothing + DoEval expr -> interactiveUI dflags srcs (Just expr) + + exitWith ExitSuccess - case mode of - DoMake -> doMake dflags srcs - DoMkDependHS -> doMkDependHS dflags srcs - StopBefore p -> do { o_files <- compileFiles mode dflags srcs - ; doLink dflags p o_files } #ifndef GHCI - DoInteractive -> noInteractiveError - DoEval _ -> noInteractiveError - where - noInteractiveError = throwDyn (CmdLineError "not built for interactive use") -#else - DoInteractive -> interactiveUI dflags srcs Nothing - DoEval expr -> interactiveUI dflags srcs (Just expr) +interactiveUI _ _ _ = + throwDyn (CmdLineError "not built for interactive use") #endif + -- ----------------------------------------------------------------------------- -- Option sanity checks -checkOptions :: GhcMode -> [String] -> [String] -> IO () +checkOptions :: CmdLineMode -> DynFlags -> [String] -> [String] -> IO () -- Final sanity checking before kicking off a compilation (pipeline). -checkOptions mode srcs objs = do +checkOptions cli_mode dflags srcs objs = do -- Complain about any unknown flags let unknown_opts = [ f | f@('-':_) <- srcs ] when (notNull unknown_opts) (unknownFlagsErr unknown_opts) + -- -prof and --interactive are not a good combination + when (notNull (wayNames dflags) && isInterpretiveMode cli_mode) $ + do throwDyn (UsageError + "--interactive can't be used with -prof, -ticky, -unreg or -smp.") -- -ohi sanity check - ohi <- readIORef v_Output_hi - if (isJust ohi && - (isCompManagerMode mode || srcs `lengthExceeds` 1)) + if (isJust (outputHi dflags) && + (isCompManagerMode cli_mode || srcs `lengthExceeds` 1)) then throwDyn (UsageError "-ohi can only be used when compiling a single source file") else do -- -o sanity checking - o_file <- readIORef v_Output_file - if (srcs `lengthExceeds` 1 && isJust o_file && not (isLinkMode mode)) + if (srcs `lengthExceeds` 1 && isJust (outputFile dflags) + && not (isLinkMode cli_mode)) then throwDyn (UsageError "can't apply -o to multiple source files") else do -- Check that there are some input files -- (except in the interactive case) - if null srcs && null objs && not (isInterpretiveMode mode) + if null srcs && null objs && not (isInterpretiveMode cli_mode) then throwDyn (UsageError "no input files") else do -- Verify that output files point somewhere sensible. - verifyOutputFiles + verifyOutputFiles dflags + + +-- Compiler output options + +-- called to verify that the output files & directories +-- 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 + let odir = outputDir dflags + when (isJust odir) $ do + let dir = fromJust odir + flg <- doesDirectoryExist dir + when (not flg) (nonExistentDir "-odir" dir) + let ofile = outputFile dflags + when (isJust ofile) $ do + let fn = fromJust ofile + flg <- doesDirNameExist fn + when (not flg) (nonExistentDir "-o" fn) + let ohi = outputHi dflags + when (isJust ohi) $ do + let hi = fromJust ohi + flg <- doesDirNameExist hi + when (not flg) (nonExistentDir "-ohi" hi) + where + nonExistentDir flg dir = + throwDyn (CmdLineError ("error: directory portion of " ++ + show dir ++ " does not exist (used with " ++ + show flg ++ " option.)")) + +----------------------------------------------------------------------------- +-- GHC modes of operation + +data CmdLineMode + = ShowUsage -- ghc -? + | PrintLibdir -- ghc --print-libdir + | ShowVersion -- ghc -V/--version + | ShowNumVersion -- ghc --numeric-version + | ShowInterface String -- ghc --show-iface + | DoMkDependHS -- ghc -M + | StopBefore Phase -- ghc -E | -C | -S + -- StopBefore StopLn is the default + | DoMake -- ghc --make + | DoInteractive -- ghc --interactive + | DoEval String -- ghc -e + deriving (Show) + +isInteractiveMode, isInterpretiveMode :: CmdLineMode -> Bool +isLinkMode, isCompManagerMode :: CmdLineMode -> Bool + +isInteractiveMode DoInteractive = True +isInteractiveMode _ = False + +-- isInterpretiveMode: byte-code compiler involved +isInterpretiveMode DoInteractive = True +isInterpretiveMode (DoEval _) = True +isInterpretiveMode _ = False + +-- True if we are going to attempt to link in this mode. +-- (we might not actually link, depending on the GhcLink flag) +isLinkMode (StopBefore StopLn) = True +isLinkMode DoMake = True +isLinkMode _ = False + +isCompManagerMode DoMake = True +isCompManagerMode DoInteractive = True +isCompManagerMode (DoEval _) = True +isCompManagerMode _ = False + + +-- ----------------------------------------------------------------------------- +-- Parsing the mode flag + +parseModeFlags :: [String] -> IO (CmdLineMode, [String]) +parseModeFlags args = do + let ((leftover, errs), (mode, _, flags)) = + runCmdLine (processArgs mode_flags args) (StopBefore StopLn, "", []) + when (not (null errs)) $ do + throwDyn (UsageError (unlines errs)) + return (mode, flags ++ leftover) + +type ModeM a = CmdLineP (CmdLineMode, String, [String]) a + -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) + -- so we collect the new ones and return them. + +mode_flags :: [(String, OptKind (CmdLineP (CmdLineMode, String, [String])))] +mode_flags = + [ ------- help / version ---------------------------------------------- + ( "?" , PassFlag (setMode ShowUsage)) + , ( "-help" , PassFlag (setMode ShowUsage)) + , ( "-print-libdir" , PassFlag (setMode PrintLibdir)) + , ( "V" , PassFlag (setMode ShowVersion)) + , ( "-version" , PassFlag (setMode ShowVersion)) + , ( "-numeric-version", PassFlag (setMode ShowNumVersion)) + + ------- interfaces ---------------------------------------------------- + , ( "-show-iface" , HasArg (\f -> setMode (ShowInterface f) + "--show-iface")) + + ------- primary modes ------------------------------------------------ + , ( "M" , PassFlag (setMode DoMkDependHS)) + , ( "E" , PassFlag (setMode (StopBefore anyHsc))) + , ( "C" , PassFlag (\f -> do setMode (StopBefore HCc) f + addFlag "-fvia-C")) + , ( "S" , PassFlag (setMode (StopBefore As))) + , ( "-make" , PassFlag (setMode DoMake)) + , ( "-interactive" , PassFlag (setMode DoInteractive)) + , ( "e" , HasArg (\s -> setMode (DoEval s) "-e")) + + -- -fno-code says to stop after Hsc but don't generate any code. + , ( "fno-code" , PassFlag (\f -> do setMode (StopBefore HCc) f + addFlag "-fno-code" + addFlag "-no-recomp")) + ] + +setMode :: CmdLineMode -> String -> ModeM () +setMode m flag = do + (old_mode, old_flag, flags) <- getCmdLineState + when (notNull old_flag && flag /= old_flag) $ + throwDyn (UsageError + ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'")) + putCmdLineState (m, flag, flags) + +addFlag :: String -> ModeM () +addFlag s = do + (m, f, flags) <- getCmdLineState + putCmdLineState (m, f, s:flags) + -- ----------------------------------------------------------------------------- -- Compile files in one-shot mode. -compileFiles :: GhcMode +oneShot :: DynFlags -> Phase -> [String] -> IO () +oneShot dflags stop_phase srcs = do + o_files <- compileFiles stop_phase dflags srcs + doLink dflags stop_phase o_files + +compileFiles :: Phase -> DynFlags -> [String] -- Source files -> IO [String] -- Object files -compileFiles mode dflags srcs = mapM (compileFile mode dflags) srcs +compileFiles stop_phase dflags srcs + = mapM (compileFile stop_phase dflags) srcs + +compileFile :: Phase -> DynFlags -> FilePath -> IO FilePath +compileFile stop_phase dflags src = do + exists <- doesFileExist src + when (not exists) $ + throwDyn (CmdLineError ("does not exist: " ++ src)) + + let + split = dopt Opt_SplitObjs dflags + o_file = outputFile dflags + ghc_link = ghcLink dflags -- Set by -c or -no-link + + -- When linking, the -o argument refers to the linker's output. + -- otherwise, we use it as the name for the pipeline's output. + maybe_o_file + | StopLn <- stop_phase, not (isNoLink ghc_link) = Nothing + -- -o foo applies to linker + | otherwise = o_file + -- -o foo applies to the file we are compiling now + + stop_phase' = case stop_phase of + As | split -> SplitAs + other -> stop_phase + + (_, out_file) <- runPipeline stop_phase' dflags + True maybe_o_file src Nothing{-no ModLocation-} + return out_file doLink :: DynFlags -> Phase -> [FilePath] -> IO () @@ -283,12 +424,10 @@ doLink dflags stop_phase o_files = return () -- We stopped before the linking phase | otherwise - = do { ghc_link <- readIORef v_GhcLink - ; case ghc_link of - NoLink -> return () - StaticLink -> staticLink dflags o_files link_pkgs - MkDLL -> doMkDLL dflags o_files link_pkgs - } + = case ghcLink dflags of + NoLink -> return () + StaticLink -> staticLink dflags o_files link_pkgs + MkDLL -> doMkDLL dflags o_files link_pkgs where -- Always link in the haskell98 package for static linking. Other -- packages have to be specified via the -package flag. @@ -303,17 +442,18 @@ doLink dflags stop_phase o_files doMake :: DynFlags -> [String] -> IO () doMake dflags [] = throwDyn (UsageError "no input files") doMake dflags srcs = do - state <- cmInit Batch dflags + state <- cmInit dflags graph <- cmDepAnal state srcs (_, ok_flag, _) <- cmLoadModules state graph when (failed ok_flag) (exitWith (ExitFailure 1)) return () + -- --------------------------------------------------------------------------- -- Various banners and verbosity output. -showBanner :: GhcMode -> DynFlags -> IO () -showBanner mode dflags = do +showBanner :: CmdLineMode -> DynFlags -> IO () +showBanner cli_mode dflags = do let verb = verbosity dflags -- Show the GHCi banner # ifdef GHCI @@ -322,8 +462,32 @@ showBanner mode dflags = do # endif -- Display details of the configuration in verbose mode - when (not (isInteractiveMode mode) && verb >= 2) $ + when (not (isInteractiveMode cli_mode) && verb >= 2) $ do hPutStr stderr "Glasgow Haskell Compiler, Version " hPutStr stderr cProjectVersion hPutStr stderr ", for Haskell 98, compiled by GHC version " hPutStrLn stderr cBooterVersion + +showVersion :: IO () +showVersion = do + putStrLn (cProjectName ++ ", version " ++ cProjectVersion) + exitWith ExitSuccess + +showGhcUsage cli_mode = do + (ghc_usage_path,ghci_usage_path) <- getUsageMsgPaths + let usage_path + | DoInteractive <- cli_mode = ghci_usage_path + | otherwise = ghc_usage_path + usage <- readFile usage_path + dump usage + exitWith ExitSuccess + where + dump "" = return () + dump ('$':'$':s) = hPutStr stderr progName >> dump s + dump (c:s) = hPutChar stderr c >> dump s + +-- ----------------------------------------------------------------------------- +-- Util + +unknownFlagsErr :: [String] -> a +unknownFlagsErr fs = throwDyn (UsageError ("unrecognised flags: " ++ unwords fs)) diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs index bc83440..ac26a9a 100644 --- a/ghc/compiler/main/Packages.lhs +++ b/ghc/compiler/main/Packages.lhs @@ -37,10 +37,10 @@ where #include "HsVersions.h" import PackageConfig -import DriverState ( v_Build_tag, v_RTS_Build_tag, v_Static ) import SysTools ( getTopDir, getPackageConfigPath ) import ParsePkgConf ( loadPackageConfig ) -import CmdLineOpts ( DynFlags(..), PackageFlag(..), opt_Static ) +import DynFlags ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..) ) +import StaticFlags ( opt_Static ) import Config ( cProjectVersion ) import Name ( Name, nameModule_maybe ) import Module ( Module, mkModule ) @@ -207,7 +207,7 @@ readPackageConfigs dflags = do ++ '-':cProjectVersion ++ "/package.conf" -- exists <- doesFileExist pkgconf - pkg_map2 <- if (readUserPkgConf dflags && exists) + pkg_map2 <- if (dopt Opt_ReadUserPackageConf dflags && exists) then readPackageConfig dflags pkg_map1 pkgconf else return pkg_map1 @@ -433,11 +433,10 @@ getPackageLibraryPath dflags pkgs = do getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String] getPackageLinkOpts dflags pkgs = do ps <- getExplicitPackagesAnd dflags pkgs - tag <- readIORef v_Build_tag - rts_tag <- readIORef v_RTS_Build_tag - static <- readIORef v_Static + let tag = buildTag dflags + rts_tag = rtsBuildTag dflags let - imp = if static then "" else "_dyn" + imp = if opt_Static then "" else "_dyn" libs p = map ((++imp) . addSuffix) (hACK (hsLibraries p)) ++ extraLibraries p all_opts p = map ("-l" ++) (libs p) ++ ldOptions p diff --git a/ghc/compiler/main/ParsePkgConf.y b/ghc/compiler/main/ParsePkgConf.y index 3aae806..6d3f0df 100644 --- a/ghc/compiler/main/ParsePkgConf.y +++ b/ghc/compiler/main/ParsePkgConf.y @@ -5,7 +5,7 @@ module ParsePkgConf( loadPackageConfig ) where import PackageConfig import Lexer -import CmdLineOpts +import DynFlags import FastString import StringBuffer import ErrUtils ( mkLocMessage ) diff --git a/ghc/compiler/main/StaticFlags.hs b/ghc/compiler/main/StaticFlags.hs new file mode 100644 index 0000000..0bce0d1 --- /dev/null +++ b/ghc/compiler/main/StaticFlags.hs @@ -0,0 +1,632 @@ +----------------------------------------------------------------------------- +-- +-- Static flags +-- +-- Static flags can only be set once, on the command-line. Inside GHC, +-- each static flag corresponds to a top-level value, usually of type Bool. +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module StaticFlags ( + parseStaticFlags, + staticFlags, + + -- Ways + WayName(..), v_Ways, v_Build_tag, v_RTS_Build_tag, + + -- Output style options + opt_PprUserLength, + opt_PprStyle_Debug, + + -- profiling opts + opt_AutoSccsOnAllToplevs, + opt_AutoSccsOnExportedToplevs, + opt_AutoSccsOnIndividualCafs, + opt_SccProfilingOn, + opt_DoTickyProfiling, + + -- language opts + opt_DictsStrict, + opt_MaxContextReductionDepth, + opt_IrrefutableTuples, + opt_Parallel, + opt_SMP, + opt_RuntimeTypes, + opt_Flatten, + + -- optimisation opts + opt_NoMethodSharing, + opt_NoStateHack, + opt_LiberateCaseThreshold, + opt_CprOff, + opt_RulesOff, + opt_SimplNoPreInlining, + opt_SimplExcessPrecision, + opt_MaxWorkerArgs, + + -- Unfolding control + opt_UF_CreationThreshold, + opt_UF_UseThreshold, + opt_UF_FunAppDiscount, + opt_UF_KeenessFactor, + opt_UF_UpdateInPlace, + opt_UF_DearOp, + + -- misc opts + opt_IgnoreDotGhci, + opt_ErrorSpans, + opt_EmitCExternDecls, + opt_SplitObjs, + opt_GranMacros, + opt_HiVersion, + opt_HistorySize, + opt_OmitBlackHoling, + opt_Static, + opt_Unregisterised, + opt_EmitExternalCore, + opt_PIC, + v_Ld_inputs, + ) where + +#include "HsVersions.h" + +import DriverPhases +import Util ( consIORef ) +import CmdLineParser +import Config ( cProjectVersionInt, cProjectPatchLevel, + cGhcUnregisterised ) +import FastString ( FastString, mkFastString ) +import Util +import Maybes ( firstJust ) +import Panic ( GhcException(..), ghcError ) +import Constants ( mAX_CONTEXT_REDUCTION_DEPTH ) + +import EXCEPTION ( throwDyn ) +import DATA_IOREF +import UNSAFE_IO ( unsafePerformIO ) +import Monad ( when ) +import Char ( isDigit ) +import IO ( hPutStrLn, stderr ) -- ToDo: should use errorMsg +import List ( sort, intersperse ) + +----------------------------------------------------------------------------- +-- Static flags + +parseStaticFlags :: [String] -> IO [String] +parseStaticFlags args = do + (leftover, errs) <- processArgs static_flags args + when (not (null errs)) $ throwDyn (UsageError (unlines errs)) + + -- deal with the way flags: the way (eg. prof) gives rise to + -- futher flags, some of which might be static. + way_flags <- findBuildTag + + -- if we're unregisterised, add some more flags + let unreg_flags | cGhcUnregisterised == "YES" = unregFlags + | otherwise = [] + + (more_leftover, errs) <- processArgs static_flags (unreg_flags ++ way_flags) + when (not (null errs)) $ ghcError (UsageError (unlines errs)) + return (more_leftover++leftover) + + +-- note that ordering is important in the following list: any flag which +-- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override +-- flags further down the list with the same prefix. + +static_flags :: [(String, OptKind IO)] +static_flags = [ + ------- GHCi ------------------------------------------------------- + ( "ignore-dot-ghci", PassFlag addOpt ) + , ( "read-dot-ghci" , NoArg (removeOpt "-ignore-dot-ghci") ) + + ------- ways -------------------------------------------------------- + , ( "prof" , NoArg (addWay WayProf) ) + , ( "unreg" , NoArg (addWay WayUnreg) ) + , ( "ticky" , NoArg (addWay WayTicky) ) + , ( "parallel" , NoArg (addWay WayPar) ) + , ( "gransim" , NoArg (addWay WayGran) ) + , ( "smp" , NoArg (addWay WaySMP) ) + , ( "debug" , NoArg (addWay WayDebug) ) + , ( "ndp" , NoArg (addWay WayNDP) ) + , ( "threaded" , NoArg (addWay WayThreaded) ) + -- ToDo: user ways + + ------ Debugging ---------------------------------------------------- + , ( "dppr-noprags", PassFlag addOpt ) + , ( "dppr-debug", PassFlag addOpt ) + , ( "dppr-user-length", AnySuffix addOpt ) + -- rest of the debugging flags are dynamic + + --------- Profiling -------------------------------------------------- + , ( "auto-all" , NoArg (addOpt "-fauto-sccs-on-all-toplevs") ) + , ( "auto" , NoArg (addOpt "-fauto-sccs-on-exported-toplevs") ) + , ( "caf-all" , NoArg (addOpt "-fauto-sccs-on-individual-cafs") ) + -- "ignore-sccs" doesn't work (ToDo) + + , ( "no-auto-all" , NoArg (removeOpt "-fauto-sccs-on-all-toplevs") ) + , ( "no-auto" , NoArg (removeOpt "-fauto-sccs-on-exported-toplevs") ) + , ( "no-caf-all" , NoArg (removeOpt "-fauto-sccs-on-individual-cafs") ) + + ------- Miscellaneous ----------------------------------------------- + , ( "no-link-chk" , NoArg (return ()) ) -- ignored for backwards compat + + , ( "split-objs" , NoArg (if can_split + then addOpt "-split-objs" + else hPutStrLn stderr + "warning: don't know how to split object files on this architecture" + ) ) + + ----- Linker -------------------------------------------------------- + , ( "static" , PassFlag addOpt ) + , ( "dynamic" , NoArg (removeOpt "-static") ) + , ( "rdynamic" , NoArg (return ()) ) -- ignored for compat w/ gcc + + ----- RTS opts ------------------------------------------------------ + , ( "H" , HasArg (setHeapSize . fromIntegral . decodeSize) ) + , ( "Rghc-timing" , NoArg (enableTimingStats) ) + + ------ Compiler flags ----------------------------------------------- + -- All other "-fno-" options cancel out "-f" on the hsc cmdline + , ( "fno-", PrefixPred (\s -> isStaticFlag ("f"++s)) + (\s -> removeOpt ("-f"++s)) ) + + -- Pass all remaining "-f" options to hsc + , ( "f", AnySuffixPred (isStaticFlag) addOpt ) + ] + +addOpt = consIORef v_opt_C + +addWay = consIORef v_Ways + +removeOpt f = do + fs <- readIORef v_opt_C + writeIORef v_opt_C $! filter (/= f) fs + +lookUp :: FastString -> Bool +lookup_def_int :: String -> Int -> Int +lookup_def_float :: String -> Float -> Float +lookup_str :: String -> Maybe String + +-- holds the static opts while they're being collected, before +-- being unsafely read by unpacked_static_opts below. +GLOBAL_VAR(v_opt_C, defaultStaticOpts, [String]) +staticFlags = unsafePerformIO (readIORef v_opt_C) + +-- -static is the default +defaultStaticOpts = ["-static"] + +packed_static_opts = map mkFastString staticFlags + +lookUp sw = sw `elem` packed_static_opts + +-- (lookup_str "foo") looks for the flag -foo=X or -fooX, +-- and returns the string X +lookup_str sw + = case firstJust (map (startsWith sw) staticFlags) of + Just ('=' : str) -> Just str + Just str -> Just str + Nothing -> Nothing + +lookup_def_int sw def = case (lookup_str sw) of + Nothing -> def -- Use default + Just xx -> try_read sw xx + +lookup_def_float sw def = case (lookup_str sw) of + Nothing -> def -- Use default + Just xx -> try_read sw xx + + +try_read :: Read a => String -> String -> a +-- (try_read sw str) tries to read s; if it fails, it +-- bleats about flag sw +try_read sw str + = case reads str of + ((x,_):_) -> x -- Be forgiving: ignore trailing goop, and alternative parses + [] -> ghcError (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw)) + -- ToDo: hack alert. We should really parse the arugments + -- and announce errors in a more civilised way. + + +{- + Putting the compiler options into temporary at-files + may turn out to be necessary later on if we turn hsc into + a pure Win32 application where I think there's a command-line + length limit of 255. unpacked_opts understands the @ option. + +unpacked_opts :: [String] +unpacked_opts = + concat $ + map (expandAts) $ + map unpackFS argv -- NOT ARGV any more: v_Static_hsc_opts + where + expandAts ('@':fname) = words (unsafePerformIO (readFile fname)) + expandAts l = [l] +-} + + +opt_IgnoreDotGhci = lookUp FSLIT("-ignore-dot-ghci") + +-- debugging opts +opt_PprStyle_Debug = lookUp FSLIT("-dppr-debug") +opt_PprUserLength = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name + +-- profiling opts +opt_AutoSccsOnAllToplevs = lookUp FSLIT("-fauto-sccs-on-all-toplevs") +opt_AutoSccsOnExportedToplevs = lookUp FSLIT("-fauto-sccs-on-exported-toplevs") +opt_AutoSccsOnIndividualCafs = lookUp FSLIT("-fauto-sccs-on-individual-cafs") +opt_SccProfilingOn = lookUp FSLIT("-fscc-profiling") +opt_DoTickyProfiling = lookUp FSLIT("-fticky-ticky") + +-- language opts +opt_DictsStrict = lookUp FSLIT("-fdicts-strict") +opt_IrrefutableTuples = lookUp FSLIT("-firrefutable-tuples") +opt_MaxContextReductionDepth = lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH +opt_Parallel = lookUp FSLIT("-fparallel") +opt_SMP = lookUp FSLIT("-fsmp") +opt_Flatten = lookUp FSLIT("-fflatten") + +-- optimisation opts +opt_NoStateHack = lookUp FSLIT("-fno-state-hack") +opt_NoMethodSharing = lookUp FSLIT("-fno-method-sharing") +opt_CprOff = lookUp FSLIT("-fcpr-off") +opt_RulesOff = lookUp FSLIT("-frules-off") + -- Switch off CPR analysis in the new demand analyser +opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" (10::Int) +opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int) + +opt_EmitCExternDecls = lookUp FSLIT("-femit-extern-decls") +opt_SplitObjs = lookUp FSLIT("-split-objs") +opt_GranMacros = lookUp FSLIT("-fgransim") +opt_HiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Int +opt_HistorySize = lookup_def_int "-fhistory-size" 20 +opt_OmitBlackHoling = lookUp FSLIT("-dno-black-holing") +opt_RuntimeTypes = lookUp FSLIT("-fruntime-types") + +-- Simplifier switches +opt_SimplNoPreInlining = lookUp FSLIT("-fno-pre-inlining") + -- NoPreInlining is there just to see how bad things + -- get if you don't do it! +opt_SimplExcessPrecision = lookUp FSLIT("-fexcess-precision") + +-- Unfolding control +opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (45::Int) +opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (8::Int) -- Discounts can be big +opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int) -- It's great to inline a fn +opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float) +opt_UF_UpdateInPlace = lookUp FSLIT("-funfolding-update-in-place") + +opt_UF_DearOp = ( 4 :: Int) + +opt_Static = lookUp FSLIT("-static") +opt_Unregisterised = lookUp FSLIT("-funregisterised") +opt_EmitExternalCore = lookUp FSLIT("-fext-core") + +-- Include full span info in error messages, instead of just the start position. +opt_ErrorSpans = lookUp FSLIT("-ferror-spans") + +opt_PIC = lookUp FSLIT("-fPIC") + +-- object files and libraries to be linked in are collected here. +-- ToDo: perhaps this could be done without a global, it wasn't obvious +-- how to do it though --SDM. +GLOBAL_VAR(v_Ld_inputs, [], [String]) + +isStaticFlag f = + f `elem` [ + "fauto-sccs-on-all-toplevs", + "fauto-sccs-on-exported-toplevs", + "fauto-sccs-on-individual-cafs", + "fscc-profiling", + "fticky-ticky", + "fall-strict", + "fdicts-strict", + "firrefutable-tuples", + "fparallel", + "fsmp", + "fflatten", + "fsemi-tagging", + "flet-no-escape", + "femit-extern-decls", + "fglobalise-toplev-names", + "fgransim", + "fno-hi-version-check", + "dno-black-holing", + "fno-method-sharing", + "fno-state-hack", + "fruntime-types", + "fno-pre-inlining", + "fexcess-precision", + "funfolding-update-in-place", + "static", + "funregisterised", + "fext-core", + "frule-check", + "frules-off", + "fcpr-off", + "ferror-spans", + "fPIC" + ] + || any (flip prefixMatch f) [ + "fcontext-stack", + "fliberate-case-threshold", + "fmax-worker-args", + "fhistory-size", + "funfolding-creation-threshold", + "funfolding-use-threshold", + "funfolding-fun-discount", + "funfolding-keeness-factor" + ] + + + +-- Misc functions for command-line options + +startsWith :: String -> String -> Maybe String +-- startsWith pfx (pfx++rest) = Just rest + +startsWith [] str = Just str +startsWith (c:cs) (s:ss) + = if c /= s then Nothing else startsWith cs ss +startsWith _ [] = Nothing + + +----------------------------------------------------------------------------- +-- convert sizes like "3.5M" into integers + +decodeSize :: String -> Integer +decodeSize str + | c == "" = truncate n + | c == "K" || c == "k" = truncate (n * 1000) + | c == "M" || c == "m" = truncate (n * 1000 * 1000) + | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000) + | otherwise = throwDyn (CmdLineError ("can't decode size: " ++ str)) + where (m, c) = span pred str + n = read m :: Double + pred c = isDigit c || c == '.' + + +----------------------------------------------------------------------------- +-- RTS Hooks + +#if __GLASGOW_HASKELL__ >= 504 +foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO () +foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO () +#else +foreign import "setHeapSize" unsafe setHeapSize :: Int -> IO () +foreign import "enableTimingStats" unsafe enableTimingStats :: IO () +#endif + +-- ----------------------------------------------------------------------------- +-- Splitting + +can_split :: Bool +can_split = +#if defined(i386_TARGET_ARCH) \ + || defined(alpha_TARGET_ARCH) \ + || defined(hppa_TARGET_ARCH) \ + || defined(m68k_TARGET_ARCH) \ + || defined(mips_TARGET_ARCH) \ + || defined(powerpc_TARGET_ARCH) \ + || defined(rs6000_TARGET_ARCH) \ + || defined(sparc_TARGET_ARCH) + True +#else + False +#endif + +----------------------------------------------------------------------------- +-- Ways + +-- The central concept of a "way" is that all objects in a given +-- program must be compiled in the same "way". Certain options change +-- parameters of the virtual machine, eg. profiling adds an extra word +-- to the object header, so profiling objects cannot be linked with +-- non-profiling objects. + +-- After parsing the command-line options, we determine which "way" we +-- are building - this might be a combination way, eg. profiling+ticky-ticky. + +-- We then find the "build-tag" associated with this way, and this +-- becomes the suffix used to find .hi files and libraries used in +-- this compilation. + +GLOBAL_VAR(v_Build_tag, "", String) + +-- The RTS has its own build tag, because there are some ways that +-- affect the RTS only. +GLOBAL_VAR(v_RTS_Build_tag, "", String) + +data WayName + = WayThreaded + | WayDebug + | WayProf + | WayUnreg + | WayTicky + | WayPar + | WayGran + | WaySMP + | WayNDP + | WayUser_a + | WayUser_b + | WayUser_c + | WayUser_d + | WayUser_e + | WayUser_f + | WayUser_g + | WayUser_h + | WayUser_i + | WayUser_j + | WayUser_k + | WayUser_l + | WayUser_m + | WayUser_n + | WayUser_o + | WayUser_A + | WayUser_B + deriving (Eq,Ord) + +GLOBAL_VAR(v_Ways, [] ,[WayName]) + +allowed_combination way = and [ x `allowedWith` y + | x <- way, y <- way, x < y ] + where + -- Note ordering in these tests: the left argument is + -- <= the right argument, according to the Ord instance + -- on Way above. + + -- debug is allowed with everything + _ `allowedWith` WayDebug = True + WayDebug `allowedWith` _ = True + + WayThreaded `allowedWith` WayProf = True + WayProf `allowedWith` WayUnreg = True + WayProf `allowedWith` WaySMP = True + WayProf `allowedWith` WayNDP = True + _ `allowedWith` _ = False + + +findBuildTag :: IO [String] -- new options +findBuildTag = do + way_names <- readIORef v_Ways + let ws = sort way_names + if not (allowed_combination ws) + then throwDyn (CmdLineError $ + "combination not supported: " ++ + foldr1 (\a b -> a ++ '/':b) + (map (wayName . lkupWay) ws)) + else let ways = map lkupWay ws + tag = mkBuildTag (filter (not.wayRTSOnly) ways) + rts_tag = mkBuildTag ways + flags = map wayOpts ways + in do + writeIORef v_Build_tag tag + writeIORef v_RTS_Build_tag rts_tag + return (concat flags) + +mkBuildTag :: [Way] -> String +mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) + +lkupWay w = + case lookup w way_details of + Nothing -> error "findBuildTag" + Just details -> details + +data Way = Way { + wayTag :: String, + wayRTSOnly :: Bool, + wayName :: String, + wayOpts :: [String] + } + +way_details :: [ (WayName, Way) ] +way_details = + [ (WayThreaded, Way "thr" True "Threaded" [ +#if defined(freebsd_TARGET_OS) + "-optc-pthread" + , "-optl-pthread" +#endif + ] ), + + (WayDebug, Way "debug" True "Debug" [] ), + + (WayProf, Way "p" False "Profiling" + [ "-fscc-profiling" + , "-DPROFILING" + , "-optc-DPROFILING" + , "-fvia-C" ]), + + (WayTicky, Way "t" False "Ticky-ticky Profiling" + [ "-fticky-ticky" + , "-DTICKY_TICKY" + , "-optc-DTICKY_TICKY" + , "-fvia-C" ]), + + (WayUnreg, Way "u" False "Unregisterised" + unregFlags ), + + -- optl's below to tell linker where to find the PVM library -- HWL + (WayPar, Way "mp" False "Parallel" + [ "-fparallel" + , "-D__PARALLEL_HASKELL__" + , "-optc-DPAR" + , "-package concurrent" + , "-optc-w" + , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" + , "-optl-lpvm3" + , "-optl-lgpvm3" + , "-fvia-C" ]), + + -- at the moment we only change the RTS and could share compiler and libs! + (WayPar, Way "mt" False "Parallel ticky profiling" + [ "-fparallel" + , "-D__PARALLEL_HASKELL__" + , "-optc-DPAR" + , "-optc-DPAR_TICKY" + , "-package concurrent" + , "-optc-w" + , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" + , "-optl-lpvm3" + , "-optl-lgpvm3" + , "-fvia-C" ]), + + (WayPar, Way "md" False "Distributed" + [ "-fparallel" + , "-D__PARALLEL_HASKELL__" + , "-D__DISTRIBUTED_HASKELL__" + , "-optc-DPAR" + , "-optc-DDIST" + , "-package concurrent" + , "-optc-w" + , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" + , "-optl-lpvm3" + , "-optl-lgpvm3" + , "-fvia-C" ]), + + (WayGran, Way "mg" False "GranSim" + [ "-fgransim" + , "-D__GRANSIM__" + , "-optc-DGRAN" + , "-package concurrent" + , "-fvia-C" ]), + + (WaySMP, Way "s" False "SMP" + [ "-fsmp" + , "-optc-pthread" +#ifndef freebsd_TARGET_OS + , "-optl-pthread" +#endif + , "-optc-DSMP" + , "-fvia-C" ]), + + (WayNDP, Way "ndp" False "Nested data parallelism" + [ "-fparr" + , "-fflatten"]), + + (WayUser_a, Way "a" False "User way 'a'" ["$WAY_a_REAL_OPTS"]), + (WayUser_b, Way "b" False "User way 'b'" ["$WAY_b_REAL_OPTS"]), + (WayUser_c, Way "c" False "User way 'c'" ["$WAY_c_REAL_OPTS"]), + (WayUser_d, Way "d" False "User way 'd'" ["$WAY_d_REAL_OPTS"]), + (WayUser_e, Way "e" False "User way 'e'" ["$WAY_e_REAL_OPTS"]), + (WayUser_f, Way "f" False "User way 'f'" ["$WAY_f_REAL_OPTS"]), + (WayUser_g, Way "g" False "User way 'g'" ["$WAY_g_REAL_OPTS"]), + (WayUser_h, Way "h" False "User way 'h'" ["$WAY_h_REAL_OPTS"]), + (WayUser_i, Way "i" False "User way 'i'" ["$WAY_i_REAL_OPTS"]), + (WayUser_j, Way "j" False "User way 'j'" ["$WAY_j_REAL_OPTS"]), + (WayUser_k, Way "k" False "User way 'k'" ["$WAY_k_REAL_OPTS"]), + (WayUser_l, Way "l" False "User way 'l'" ["$WAY_l_REAL_OPTS"]), + (WayUser_m, Way "m" False "User way 'm'" ["$WAY_m_REAL_OPTS"]), + (WayUser_n, Way "n" False "User way 'n'" ["$WAY_n_REAL_OPTS"]), + (WayUser_o, Way "o" False "User way 'o'" ["$WAY_o_REAL_OPTS"]), + (WayUser_A, Way "A" False "User way 'A'" ["$WAY_A_REAL_OPTS"]), + (WayUser_B, Way "B" False "User way 'B'" ["$WAY_B_REAL_OPTS"]) + ] + +unregFlags = + [ "-optc-DNO_REGS" + , "-optc-DUSE_MINIINTERPRETER" + , "-fno-asm-mangling" + , "-funregisterised" + , "-fvia-C" ] diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index 738e63f..9710bcb 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -11,22 +11,6 @@ module SysTools ( -- Initialisation initSysTools, - setPgmL, -- String -> IO () - setPgmP, - setPgmF, - setPgmc, - setPgmm, - setPgms, - setPgma, - setPgml, - setPgmDLL, -#ifdef ILX - setPgmI, - setPgmi, -#endif - -- Command-line override - setDryRun, - getTopDir, -- IO String -- The value of $topdir getPackageConfigPath, -- IO String -- Where package.conf is getUsageMsgPaths, -- IO (String,String) @@ -37,10 +21,6 @@ module SysTools ( runMangle, runSplit, -- [Option] -> IO () runAs, runLink, -- [Option] -> IO () runMkDLL, -#ifdef ILX - runIlx2il, runIlasm, -- [String] -> IO () -#endif - touch, -- String -> String -> IO () copy, -- String -> String -> String -> IO () @@ -64,13 +44,12 @@ module SysTools ( #include "HsVersions.h" -import DriverUtil import DriverPhases ( isHaskellUserSrcFilename ) import Config import Outputable import Panic ( GhcException(..) ) -import Util ( global, notNull ) -import CmdLineOpts ( DynFlags(..) ) +import Util ( Suffix, global, notNull, consIORef ) +import DynFlags ( DynFlags(..), DynFlag(..), dopt, Option(..) ) import EXCEPTION ( throwDyn ) import DATA_IOREF ( IORef, readIORef, writeIORef ) @@ -184,20 +163,6 @@ All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE. (See remarks under pathnames below) \begin{code} -GLOBAL_VAR(v_Pgm_L, error "pgm_L", String) -- unlit -GLOBAL_VAR(v_Pgm_P, error "pgm_P", (String,[Option])) -- cpp -GLOBAL_VAR(v_Pgm_F, error "pgm_F", String) -- pp -GLOBAL_VAR(v_Pgm_c, error "pgm_c", (String,[Option])) -- gcc -GLOBAL_VAR(v_Pgm_m, error "pgm_m", (String,[Option])) -- asm code mangler -GLOBAL_VAR(v_Pgm_s, error "pgm_s", (String,[Option])) -- asm code splitter -GLOBAL_VAR(v_Pgm_a, error "pgm_a", (String,[Option])) -- as -#ifdef ILX -GLOBAL_VAR(v_Pgm_I, error "pgm_I", String) -- ilx2il -GLOBAL_VAR(v_Pgm_i, error "pgm_i", String) -- ilasm -#endif -GLOBAL_VAR(v_Pgm_l, error "pgm_l", (String,[Option])) -- ld -GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", (String,[Option])) -- mkdll - GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp @@ -224,13 +189,14 @@ getTopDir = readIORef v_TopDir \begin{code} initSysTools :: [String] -- Command-line arguments starting "-B" - -> IO () -- Set all the mutable variables above, holding + -> DynFlags + -> IO DynFlags -- Set all the mutable variables above, holding -- (a) the system programs -- (b) the package-config file -- (c) the GHC usage message -initSysTools minusB_args +initSysTools minusB_args dflags = do { (am_installed, top_dir) <- findTopDir minusB_args ; writeIORef v_TopDir top_dir -- top_dir @@ -386,12 +352,6 @@ initSysTools minusB_args ; let (as_prog,as_args) = (gcc_prog,gcc_args) (ld_prog,ld_args) = (gcc_prog,gcc_args) -#ifdef ILX - -- ilx2il and ilasm are specified in Config.hs - ; let ilx2il_path = cILX2IL - ilasm_path = cILASM -#endif - -- Initialise the global vars ; writeIORef v_Path_package_config pkgconfig_path ; writeIORef v_Path_usages (ghc_usage_msg_path, @@ -401,23 +361,19 @@ initSysTools minusB_args -- Hans: this isn't right in general, but you can -- elaborate it in the same way as the others - ; writeIORef v_Pgm_L unlit_path - ; writeIORef v_Pgm_P cpp_path - ; writeIORef v_Pgm_F "" - ; writeIORef v_Pgm_c (gcc_prog,gcc_args) - ; writeIORef v_Pgm_m (mangle_prog,mangle_args) - ; writeIORef v_Pgm_s (split_prog,split_args) - ; writeIORef v_Pgm_a (as_prog,as_args) -#ifdef ILX - ; writeIORef v_Pgm_I ilx2il_path - ; writeIORef v_Pgm_i ilasm_path -#endif - ; writeIORef v_Pgm_l (ld_prog,ld_args) - ; writeIORef v_Pgm_MkDLL (mkdll_prog,mkdll_args) ; writeIORef v_Pgm_T touch_path ; writeIORef v_Pgm_CP cp_path - ; return () + ; return dflags{ + pgm_L = unlit_path, + pgm_P = cpp_path, + pgm_F = "", + pgm_c = (gcc_prog,gcc_args), + pgm_m = (mangle_prog,mangle_args), + pgm_s = (split_prog,split_args), + pgm_a = (as_prog,as_args), + pgm_l = (ld_prog,ld_args), + pgm_dll = (mkdll_prog,mkdll_args) } } #if defined(mingw32_HOST_OS) @@ -425,32 +381,6 @@ foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO #endif \end{code} -The various setPgm functions are called when a command-line option -like - - -pgmLld - -is used to override a particular program with a new one - -\begin{code} -setPgmL = writeIORef v_Pgm_L --- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] --- Config.hs should really use Option. -setPgmP arg = let (pgm:args) = words arg in writeIORef v_Pgm_P (pgm,map Option args) -setPgmF = writeIORef v_Pgm_F -setPgmc prog = writeIORef v_Pgm_c (prog,[]) -setPgmm prog = writeIORef v_Pgm_m (prog,[]) -setPgms prog = writeIORef v_Pgm_s (prog,[]) -setPgma prog = writeIORef v_Pgm_a (prog,[]) -setPgml prog = writeIORef v_Pgm_l (prog,[]) -setPgmDLL prog = writeIORef v_Pgm_MkDLL (prog,[]) -#ifdef ILX -setPgmI = writeIORef v_Pgm_I -setPgmi = writeIORef v_Pgm_i -#endif -\end{code} - - \begin{code} -- Find TopDir -- for "installed" this is the root of GHC's support files @@ -499,33 +429,6 @@ findTopDir minusbs %************************************************************************ %* * -\subsection{Command-line options} -n%* * -%************************************************************************ - -When invoking external tools as part of the compilation pipeline, we -pass these a sequence of options on the command-line. Rather than -just using a list of Strings, we use a type that allows us to distinguish -between filepaths and 'other stuff'. [The reason being, of course, that -this type gives us a handle on transforming filenames, and filenames only, -to whatever format they're expected to be on a particular platform.] - -\begin{code} -data Option - = FileOption -- an entry that _contains_ filename(s) / filepaths. - String -- a non-filepath prefix that shouldn't be transformed (e.g., "/out=" - String -- the filepath/filename portion - | Option String - -showOpt (FileOption pre f) = pre ++ platformPath f -showOpt (Option "") = "" -showOpt (Option s) = s - -\end{code} - - -%************************************************************************ -%* * \subsection{Running an external program} %* * %************************************************************************ @@ -534,59 +437,47 @@ showOpt (Option s) = s \begin{code} runUnlit :: DynFlags -> [Option] -> IO () runUnlit dflags args = do - p <- readIORef v_Pgm_L + let p = pgm_L dflags runSomething dflags "Literate pre-processor" p args runCpp :: DynFlags -> [Option] -> IO () runCpp dflags args = do - (p,baseArgs) <- readIORef v_Pgm_P - runSomething dflags "C pre-processor" p (baseArgs ++ args) + let (p,args0) = pgm_P dflags + runSomething dflags "C pre-processor" p (args0 ++ args) runPp :: DynFlags -> [Option] -> IO () runPp dflags args = do - p <- readIORef v_Pgm_F + let p = pgm_F dflags runSomething dflags "Haskell pre-processor" p args runCc :: DynFlags -> [Option] -> IO () runCc dflags args = do - (p,args0) <- readIORef v_Pgm_c + let (p,args0) = pgm_c dflags runSomething dflags "C Compiler" p (args0++args) runMangle :: DynFlags -> [Option] -> IO () runMangle dflags args = do - (p,args0) <- readIORef v_Pgm_m + let (p,args0) = pgm_m dflags runSomething dflags "Mangler" p (args0++args) runSplit :: DynFlags -> [Option] -> IO () runSplit dflags args = do - (p,args0) <- readIORef v_Pgm_s + let (p,args0) = pgm_s dflags runSomething dflags "Splitter" p (args0++args) runAs :: DynFlags -> [Option] -> IO () runAs dflags args = do - (p,args0) <- readIORef v_Pgm_a + let (p,args0) = pgm_a dflags runSomething dflags "Assembler" p (args0++args) runLink :: DynFlags -> [Option] -> IO () runLink dflags args = do - (p,args0) <- readIORef v_Pgm_l + let (p,args0) = pgm_l dflags runSomething dflags "Linker" p (args0++args) -#ifdef ILX -runIlx2il :: DynFlags -> [Option] -> IO () -runIlx2il dflags args = do - p <- readIORef v_Pgm_I - runSomething dflags "Ilx2Il" p args - -runIlasm :: DynFlags -> [Option] -> IO () -runIlasm dflags args = do - p <- readIORef v_Pgm_i - runSomething dflags "Ilasm" p args -#endif - runMkDLL :: DynFlags -> [Option] -> IO () runMkDLL dflags args = do - (p,args0) <- readIORef v_Pgm_MkDLL + let (p,args0) = pgm_dll dflags runSomething dflags "Make DLL" p (args0++args) touch :: DynFlags -> String -> String -> IO () @@ -603,6 +494,7 @@ copy dflags purpose from to = do -- ToDo: speed up via slurping. hPutStr h ls hClose h + \end{code} \begin{code} @@ -687,12 +579,12 @@ newTempName extn = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn b <- doesFileExist filename if b then findTempName tmp_dir (x+1) - else do add v_FilesToClean filename -- clean it up later + else do consIORef v_FilesToClean filename -- clean it up later return filename addFilesToClean :: [FilePath] -> IO () -- May include wildcards [used by DriverPipeline.run_phase SplitMangle] -addFilesToClean files = mapM_ (add v_FilesToClean) files +addFilesToClean files = mapM_ (consIORef v_FilesToClean) files removeTmpFiles :: DynFlags -> [FilePath] -> IO () removeTmpFiles dflags fs @@ -723,20 +615,6 @@ removeTmpFiles dflags fs hPutStrLn stderr ("Warning: deleting non-existent " ++ f) ) -\end{code} - - -%************************************************************************ -%* * -\subsection{Running a program} -%* * -%************************************************************************ - -\begin{code} -GLOBAL_VAR(v_Dry_run, False, Bool) - -setDryRun :: IO () -setDryRun = writeIORef v_Dry_run True ----------------------------------------------------------------------------- -- Running an external program @@ -766,6 +644,10 @@ runSomething dflags phase_name pgm args = do ExitFailure _other -> throwDyn (PhaseFailed phase_name exit_code) +showOpt (FileOption pre f) = pre ++ platformPath f +showOpt (Option "") = "" +showOpt (Option s) = s + traceCmd :: DynFlags -> String -> String -> IO () -> IO () -- a) trace the command (at two levels of verbosity) -- b) don't do it at all if dry-run is set @@ -776,8 +658,7 @@ traceCmd dflags phase_name cmd_line action ; hFlush stderr -- Test for -n flag - ; n <- readIORef v_Dry_run - ; unless n $ do { + ; unless (dopt Opt_DryRun dflags) $ do { -- And run it! ; action `IO.catch` handle_exn verb diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index ee4b5bb..73ef49d 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -8,7 +8,7 @@ module TidyPgm( tidyCorePgm, tidyCoreExpr ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) +import DynFlags ( DynFlags, DynFlag(..), dopt ) import CoreSyn import CoreUnfold ( noUnfolding, mkTopUnfolding ) import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars ) diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index 5844c89..2a7492b 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -36,8 +36,8 @@ import FastTypes import List ( groupBy, sortBy ) import CLabel ( pprCLabel ) import ErrUtils ( dumpIfSet_dyn ) -import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_Static, - opt_EnsureSplittableC, opt_PIC ) +import DynFlags ( DynFlags, DynFlag(..), dopt ) +import StaticFlags ( opt_Static, opt_SplitObjs, opt_PIC ) import Digraph import qualified Pretty @@ -133,8 +133,8 @@ nativeCodeGen dflags cmms us where add_split (Cmm tops) - | opt_EnsureSplittableC = split_marker : tops - | otherwise = tops + | opt_SplitObjs = split_marker : tops + | otherwise = tops split_marker = CmmProc [] mkSplitMarkerLabel [] [] diff --git a/ghc/compiler/nativeGen/MachCodeGen.hs b/ghc/compiler/nativeGen/MachCodeGen.hs index 20aad78..9e7787c 100644 --- a/ghc/compiler/nativeGen/MachCodeGen.hs +++ b/ghc/compiler/nativeGen/MachCodeGen.hs @@ -29,7 +29,7 @@ import MachOp import CLabel -- The rest: -import CmdLineOpts ( opt_PIC ) +import StaticFlags ( opt_PIC ) import ForeignCall ( CCallConv(..) ) import OrdList import Pretty diff --git a/ghc/compiler/nativeGen/PositionIndependentCode.hs b/ghc/compiler/nativeGen/PositionIndependentCode.hs index 936b76a..a874270 100644 --- a/ghc/compiler/nativeGen/PositionIndependentCode.hs +++ b/ghc/compiler/nativeGen/PositionIndependentCode.hs @@ -61,7 +61,7 @@ import MachRegs import MachInstrs import NCGMonad ( NatM, getNewRegNat, getNewLabelNat ) -import CmdLineOpts ( opt_PIC, opt_Static ) +import StaticFlags ( opt_PIC, opt_Static ) import Pretty import qualified Outputable diff --git a/ghc/compiler/nativeGen/PprMach.hs b/ghc/compiler/nativeGen/PprMach.hs index 0f33ca3..26b192f 100644 --- a/ghc/compiler/nativeGen/PprMach.hs +++ b/ghc/compiler/nativeGen/PprMach.hs @@ -37,7 +37,7 @@ import Pretty import FastString import qualified Outputable -import CmdLineOpts ( opt_PIC, opt_Static ) +import StaticFlags ( opt_PIC, opt_Static ) #if __GLASGOW_HASKELL__ >= 504 import Data.Array.ST diff --git a/ghc/compiler/nativeGen/RegisterAlloc.hs b/ghc/compiler/nativeGen/RegisterAlloc.hs index 4f71fe1..7c5a4bd 100644 --- a/ghc/compiler/nativeGen/RegisterAlloc.hs +++ b/ghc/compiler/nativeGen/RegisterAlloc.hs @@ -80,6 +80,58 @@ The algorithm is roughly: -} +{- +Possible plan for x86 floating pt register alloc: + + - The standard reg alloc procedure allocates pretend floating point + registers to the GXXX instructions. We need to convert these GXXX + instructions to proper x86 FXXX instructions, using the FP stack for + registers. + + We could do this in a separate pass, but it helps to have the + information about which real registers are live after the + instruction, so we do it at reg alloc time where that information + is already available. + + - keep a mapping from %fakeN to FP stack slot in the monad. + + - after assigning registers to the GXXX instruction, convert the + instruction to an FXXX instruction. eg. + - for GMOV just update the mapping, and ffree any dead regs. + - GLD: just fld and update mapping + GLDZ: just fldz and update mapping + GLD1: just fld1 and update mapping + - GST: just fst and update mapping, ffree dead regs. + - special case for GST reg, where reg is st(0), we can fstp. + - for GADD fp1, fp2, fp3: + - easy way: fld fp2 + fld fp1 + faddp + -- record that fp3 is now in %st(0), and all other + -- slots are pushed down one. + ffree fp1 -- if fp1 is dead now + ffree fp2 -- if fp2 is dead now + - optimisation #1 + - if fp1 is in %st(0) and is dead afterward + fadd %st(0), fp2 + -- record fp3 is in %st(0) + ffree fp2 -- if fp2 is dead now + - if fp2 is in %st(0) and is dead afterward + fadd %st(0), fp1 + -- record fp3 is in %st(0) + - if fp1 is in %st(0), fp2 is dead afterward + fadd fp2, %st(0) + -- record fp3 is in fp2's locn + - if fp2 is in %st(0), fp1 is dead afterward + fadd fp1, %st(0) + -- record fp3 is in fp1's locn + + - we should be able to avoid the nasty ffree problems of the current + scheme. The stack should be empty before doing a non-local + jump/call - we can assert that this is the case. +-} + + module RegisterAlloc ( regAlloc ) where diff --git a/ghc/compiler/ndpFlatten/FlattenInfo.hs b/ghc/compiler/ndpFlatten/FlattenInfo.hs index b6e91e5..3067971 100644 --- a/ghc/compiler/ndpFlatten/FlattenInfo.hs +++ b/ghc/compiler/ndpFlatten/FlattenInfo.hs @@ -22,7 +22,7 @@ module FlattenInfo ( namesNeededForFlattening ) where -import CmdLineOpts (opt_Flatten) +import StaticFlags (opt_Flatten) import NameSet (FreeVars, emptyFVs, mkFVs) import PrelNames (fstName, andName, orName, lengthPName, replicatePName, mapPName, bpermutePName, bpermuteDftPName, indexOfPName) diff --git a/ghc/compiler/ndpFlatten/Flattening.hs b/ghc/compiler/ndpFlatten/Flattening.hs index cd4bdd4..3fc1d55 100644 --- a/ghc/compiler/ndpFlatten/Flattening.hs +++ b/ghc/compiler/ndpFlatten/Flattening.hs @@ -63,11 +63,11 @@ import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext, mk'indexOfP,mk'eq,mk'neq) -- GHC -import CmdLineOpts (opt_Flatten) +import StaticFlags (opt_Flatten) import Panic (panic) import ErrUtils (dumpIfSet_dyn) import UniqSupply (mkSplitUniqSupply) -import CmdLineOpts (DynFlag(..)) +import DynFlags (DynFlag(..)) import Literal (Literal, literalType) import Var (Var(..), idType, isTyVar) import Id (setIdType) diff --git a/ghc/compiler/package.conf.in b/ghc/compiler/package.conf.in index 30719ce..57eec16 100644 --- a/ghc/compiler/package.conf.in +++ b/ghc/compiler/package.conf.in @@ -5,260 +5,259 @@ maintainer: glasgow-haskell-users@haskell.org exposed: True exposed-modules: - BasicTypes, - DataCon, - Demand, - FieldLabel, - Id, - IdInfo, - Literal, - MkId, - Module, - Name, - NameEnv, - NameSet, - NewDemand, - OccName, - RdrName, - SrcLoc, - UniqSupply, - Unique, - Var, - VarEnv, - VarSet, - CLabel, - Cmm, - CmmLex, - CmmLint, - CmmParse, - CmmUtils, - MachOp, - PprC, - PprCmm, - Bitmap, - CgBindery, - CgCallConv, - CgCase, - CgClosure, - CgCon, - CgExpr, - CgForeignCall, - CgHeapery, - CgInfoTbls, - CgLetNoEscape, - CgMonad, - CgParallel, - CgPrimOp, - CgProf, - CgStackery, - CgTailCall, - CgTicky, - CgUtils, - ClosureInfo, - CodeGen, - SMRep, - CompManager, - CoreFVs, - CoreLint, - CorePrep, - CoreSubst, - CoreSyn, - CoreTidy, - CoreUnfold, - CoreUtils, - ExternalCore, - MkExternalCore, - PprCore, - PprExternalCore, - CprAnalyse, - Check, - Desugar, - DsArrows, - DsBinds, - DsCCall, - DsExpr, - DsForeign, - DsGRHSs, - DsListComp, - DsMeta, - DsMonad, - DsUtils, - Match, - MatchCon, - MatchLit, - ByteCodeAsm, - ByteCodeFFI, - ByteCodeGen, - ByteCodeInstr, - ByteCodeItbls, - ByteCodeLink, - InteractiveUI, - Linker, - ObjLink, - Convert, - HsBinds, - HsDecls, - HsExpr, - HsImpExp, - HsLit, - HsPat, - HsSyn, - HsTypes, - HsUtils, - BinIface, - BuildTyCl, - IfaceEnv, - IfaceSyn, - IfaceType, - LoadIface, - MkIface, - TcIface, - IlxGen, - Java, - JavaGen, - PrintJava, - CmdLineOpts, - CodeOutput, - Config, - Constants, - DriverFlags, - DriverMkDepend, - DriverPhases, - DriverPipeline, - DriverState, - DriverUtil, - ErrUtils, - Finder, - GetImports, - HscMain, - HscStats, - HscTypes, - PackageConfig, - Packages, - ParsePkgConf, - SysTools, - TidyPgm, - AsmCodeGen, - MachCodeGen, - MachInstrs, - MachRegs, - NCGMonad, - PositionIndependentCode, - PprMach, - RegAllocInfo, - RegisterAlloc, - FlattenInfo, - Flattening, - FlattenMonad, - NDPCoreUtils, - PArrAnal, - Ctype, - LexCore, - Lexer, - Parser, - ParserCore, - ParserCoreUtils, - RdrHsSyn, - ForeignCall, - PrelInfo, - PrelNames, - PrelRules, - PrimOp, - TysPrim, - TysWiredIn, - CostCentre, - SCCfinal, - RnBinds, - RnEnv, - RnExpr, - RnHsSyn, - RnNames, - RnSource, - RnTypes, - CSE, - FloatIn, - FloatOut, - LiberateCase, - OccurAnal, - SAT, - SATMonad, - SetLevels, - SimplCore, - SimplEnv, - Simplify, - SimplMonad, - SimplUtils, - SimplStg, - SRT, - StgStats, - Rules, - SpecConstr, - Specialise, - CoreToStg, - StgLint, - StgSyn, - DmdAnal, - SaAbsInt, - SaLib, - StrictAnal, - WorkWrap, - WwLib, - Inst, - TcArrows, - TcBinds, - TcClassDcl, - TcDefaults, - TcDeriv, - TcEnv, - TcExpr, - TcForeign, - TcGenDeriv, - TcHsSyn, - TcHsType, - TcInstDcls, - TcMatches, - TcMType, - TcPat, - TcRnDriver, - TcRnMonad, - TcRnTypes, - TcRules, - TcSimplify, - TcSplice, - TcTyClsDecls, - TcTyDecls, - TcType, - TcUnify, - Class, - FunDeps, - Generics, - InstEnv, - Kind, - TyCon, - Type, - TypeRep, - Unify, - Bag, - Binary, - BitSet, - Digraph, - FastMutInt, - FastString, - FastTypes, - FiniteMap, - IOEnv, - ListSetOps, - Maybes, - OrdList, - Outputable, - Panic, - Pretty, - PrimPacked, - StringBuffer, - UnicodeUtil, - UniqFM, - UniqSet, - Util + BasicTypes, + CmdLineParser, + DataCon, + Demand, + DynFlags, + StaticFlags, + FieldLabel, + Id, + IdInfo, + Literal, + MkId, + Module, + Name, + NameEnv, + NameSet, + NewDemand, + OccName, + RdrName, + SrcLoc, + UniqSupply, + Unique, + Var, + VarEnv, + VarSet, + CLabel, + Cmm, + CmmLex, + CmmLint, + CmmParse, + CmmUtils, + MachOp, + PprC, + PprCmm, + Bitmap, + CgBindery, + CgCallConv, + CgCase, + CgClosure, + CgCon, + CgExpr, + CgForeignCall, + CgHeapery, + CgInfoTbls, + CgLetNoEscape, + CgMonad, + CgParallel, + CgPrimOp, + CgProf, + CgStackery, + CgTailCall, + CgTicky, + CgUtils, + ClosureInfo, + CodeGen, + SMRep, + CompManager, + CoreFVs, + CoreLint, + CorePrep, + CoreSubst, + CoreSyn, + CoreTidy, + CoreUnfold, + CoreUtils, + ExternalCore, + MkExternalCore, + PprCore, + PprExternalCore, + CprAnalyse, + Check, + Desugar, + DsArrows, + DsBinds, + DsCCall, + DsExpr, + DsForeign, + DsGRHSs, + DsListComp, + DsMeta, + DsMonad, + DsUtils, + Match, + MatchCon, + MatchLit, + ByteCodeAsm, + ByteCodeFFI, + ByteCodeGen, + ByteCodeInstr, + ByteCodeItbls, + ByteCodeLink, + InteractiveUI, + Linker, + ObjLink, + Convert, + HsBinds, + HsDecls, + HsExpr, + HsImpExp, + HsLit, + HsPat, + HsSyn, + HsTypes, + HsUtils, + BinIface, + BuildTyCl, + IfaceEnv, + IfaceSyn, + IfaceType, + LoadIface, + MkIface, + TcIface, + IlxGen, + Java, + JavaGen, + PrintJava, + CodeOutput, + Config, + Constants, + DriverMkDepend, + DriverPhases, + DriverPipeline, + ErrUtils, + Finder, + GetImports, + HscMain, + HscStats, + HscTypes, + PackageConfig, + Packages, + ParsePkgConf, + SysTools, + TidyPgm, + AsmCodeGen, + MachCodeGen, + MachInstrs, + MachRegs, + NCGMonad, + PositionIndependentCode, + PprMach, + RegAllocInfo, + RegisterAlloc, + FlattenInfo, + Flattening, + FlattenMonad, + NDPCoreUtils, + PArrAnal, + Ctype, + LexCore, + Lexer, + Parser, + ParserCore, + ParserCoreUtils, + RdrHsSyn, + ForeignCall, + PrelInfo, + PrelNames, + PrelRules, + PrimOp, + TysPrim, + TysWiredIn, + CostCentre, + SCCfinal, + RnBinds, + RnEnv, + RnExpr, + RnHsSyn, + RnNames, + RnSource, + RnTypes, + CSE, + FloatIn, + FloatOut, + LiberateCase, + OccurAnal, + SAT, + SATMonad, + SetLevels, + SimplCore, + SimplEnv, + Simplify, + SimplMonad, + SimplUtils, + SimplStg, + SRT, + StgStats, + Rules, + SpecConstr, + Specialise, + CoreToStg, + StgLint, + StgSyn, + DmdAnal, + SaAbsInt, + SaLib, + StrictAnal, + WorkWrap, + WwLib, + Inst, + TcArrows, + TcBinds, + TcClassDcl, + TcDefaults, + TcDeriv, + TcEnv, + TcExpr, + TcForeign, + TcGenDeriv, + TcHsSyn, + TcHsType, + TcInstDcls, + TcMatches, + TcMType, + TcPat, + TcRnDriver, + TcRnMonad, + TcRnTypes, + TcRules, + TcSimplify, + TcSplice, + TcTyClsDecls, + TcTyDecls, + TcType, + TcUnify, + Class, + FunDeps, + Generics, + InstEnv, + Kind, + TyCon, + Type, + TypeRep, + Unify, + Bag, + Binary, + BitSet, + Digraph, + FastMutInt, + FastString, + FastTypes, + FiniteMap, + IOEnv, + ListSetOps, + Maybes, + OrdList, + Outputable, + Panic, + Pretty, + PrimPacked, + StringBuffer, + UnicodeUtil, + UniqFM, + UniqSet, + Util #ifdef INSTALLING import-dirs: "$libdir/ghc-package" diff --git a/ghc/compiler/parser/Lexer.x b/ghc/compiler/parser/Lexer.x index 0a2f3c5..89d288a 100644 --- a/ghc/compiler/parser/Lexer.x +++ b/ghc/compiler/parser/Lexer.x @@ -38,7 +38,7 @@ import FastString import FastTypes import SrcLoc import UniqFM -import CmdLineOpts +import DynFlags import Ctype import Util ( maybePrefixMatch, readRational ) diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index 9378f76..8b85551 100644 --- a/ghc/compiler/parser/Parser.y.pp +++ b/ghc/compiler/parser/Parser.y.pp @@ -31,7 +31,7 @@ import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans, SrcSpan, combineLocs, srcLocFile, mkSrcLoc, mkSrcSpan ) import Module -import CmdLineOpts ( opt_SccProfilingOn ) +import StaticFlags ( opt_SccProfilingOn ) import Type ( Kind, mkArrowKind, liftedTypeKind ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), Activation(..) ) diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index 3a3c02c..04b24c3 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -44,7 +44,7 @@ import Maybes ( orElse ) import Name ( Name ) import Outputable import FastString -import CmdLineOpts ( opt_SimplExcessPrecision ) +import StaticFlags ( opt_SimplExcessPrecision ) import DATA_BITS ( Bits(..) ) #if __GLASGOW_HASKELL__ >= 500 diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 97aedf2..8c6bcf9 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -29,7 +29,8 @@ module SCCfinal ( stgMassageForProfiling ) where import StgSyn -import CmdLineOpts ( DynFlags, opt_AutoSccsOnIndividualCafs ) +import DynFlags ( DynFlags ) +import StaticFlags ( opt_AutoSccsOnIndividualCafs ) import CostCentre -- lots of things import Id ( Id ) import Module ( Module ) diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 291a65e..94ae27f 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -30,7 +30,7 @@ import RnEnv ( bindLocatedLocalsRn, lookupLocatedBndrRn, bindLocalFixities, bindSigTyVarsFV, warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, ) -import CmdLineOpts ( DynFlag(..) ) +import DynFlags ( DynFlag(..) ) import Digraph ( SCC(..), stronglyConnComp ) import Name ( Name, nameOccName, nameSrcLoc ) import NameSet diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 09bb3bc..a580884 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -60,7 +60,7 @@ import Outputable import Util ( sortLe ) import ListSetOps ( removeDups ) import List ( nubBy ) -import CmdLineOpts +import DynFlags \end{code} %********************************************************* diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 2281f3e..64f0370 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -32,7 +32,7 @@ import RnNames ( importsFromLocalDecls ) import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit, dupFieldErr, precParseErr, sectionPrecErr, patSigErr, checkTupSize ) -import CmdLineOpts ( DynFlag(..) ) +import DynFlags ( DynFlag(..) ) import BasicTypes ( Fixity(..), FixityDirection(..), negateFixity, compareFixity ) import PrelNames ( hasKey, assertIdKey, assertErrorName, loopAName, choiceAName, appAName, arrAName, composeAName, firstAName, diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 686f01d..2b43899 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -12,7 +12,7 @@ module RnNames ( #include "HsVersions.h" -import CmdLineOpts ( DynFlag(..) ) +import DynFlags ( DynFlag(..), GhcMode(..) ) import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl, ForeignDecl(..), HsGroup(..), HsBindGroup(..), Sig(..), collectGroupBinders, tyClDeclNames @@ -33,7 +33,7 @@ import NameSet import NameEnv import OccName ( srcDataName, isTcOcc, occNameFlavour, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOccEnv ) -import HscTypes ( GenAvailInfo(..), AvailInfo, GhciMode(..), +import HscTypes ( GenAvailInfo(..), AvailInfo, IfaceExport, HomePackageTable, PackageIfaceTable, availNames, unQualInScope, Deprecs(..), ModIface(..), Dependencies(..), diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 48838ee..653f312 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -40,7 +40,7 @@ import NameSet import NameEnv import Outputable import SrcLoc ( Located(..), unLoc, getLoc, noLoc ) -import CmdLineOpts ( DynFlag(..) ) +import DynFlags ( DynFlag(..) ) import Maybes ( seqMaybe ) import Maybe ( catMaybes, isNothing ) \end{code} diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index 15e74d0..661f0c4 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -11,7 +11,7 @@ module RnTypes ( rnHsType, rnLHsType, rnLHsTypes, rnContext, precParseErr, sectionPrecErr, dupFieldErr, patSigErr, checkTupSize ) where -import CmdLineOpts ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) ) +import DynFlags ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) ) import HsSyn import RdrHsSyn ( extractHsRhoRdrTyVars ) diff --git a/ghc/compiler/simplCore/CSE.lhs b/ghc/compiler/simplCore/CSE.lhs index 14febd6..2e8489a 100644 --- a/ghc/compiler/simplCore/CSE.lhs +++ b/ghc/compiler/simplCore/CSE.lhs @@ -10,7 +10,7 @@ module CSE ( #include "HsVersions.h" -import CmdLineOpts ( DynFlag(..), DynFlags ) +import DynFlags ( DynFlag(..), DynFlags ) import Id ( Id, idType, idWorkerInfo ) import IdInfo ( workerExists ) import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap ) diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index 0ca2257..ae6ce75 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -16,7 +16,7 @@ module FloatIn ( floatInwards ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..) ) +import DynFlags ( DynFlags, DynFlag(..) ) import CoreSyn import CoreUtils ( exprIsValue, exprIsDupable ) import CoreLint ( showPass, endPass ) diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs index e3b877e..a53d0c6 100644 --- a/ghc/compiler/simplCore/FloatOut.lhs +++ b/ghc/compiler/simplCore/FloatOut.lhs @@ -13,7 +13,7 @@ module FloatOut ( floatOutwards ) where import CoreSyn import CoreUtils ( mkSCC, exprIsValue, exprIsTrivial ) -import CmdLineOpts ( DynFlags, DynFlag(..), FloatOutSwitches(..) ) +import DynFlags ( DynFlags, DynFlag(..), FloatOutSwitches(..) ) import ErrUtils ( dumpIfSet_dyn ) import CostCentre ( dupifyCC, CostCentre ) import Id ( Id, idType ) diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs index 20c012d..c29a5b9 100644 --- a/ghc/compiler/simplCore/LiberateCase.lhs +++ b/ghc/compiler/simplCore/LiberateCase.lhs @@ -8,7 +8,8 @@ module LiberateCase ( liberateCase ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..), opt_LiberateCaseThreshold ) +import DynFlags ( DynFlags, DynFlag(..) ) +import StaticFlags ( opt_LiberateCaseThreshold ) import CoreLint ( showPass, endPass ) import CoreSyn import CoreUnfold ( couldBeSmallEnoughToInline ) diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index d8d4ff0..8f7c98c 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -55,7 +55,7 @@ module SetLevels ( import CoreSyn -import CmdLineOpts ( FloatOutSwitches(..) ) +import DynFlags ( FloatOutSwitches(..) ) import CoreUtils ( exprType, exprIsTrivial, exprIsCheap, mkPiTypes ) import CoreFVs -- all of it import CoreSubst ( Subst, emptySubst, extendInScope, extendIdSubst, diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 1421446..d785cdc 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -8,10 +8,9 @@ module SimplCore ( core2core, simplifyExpr ) where #include "HsVersions.h" -import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), +import DynFlags ( CoreToDo(..), SimplifierSwitch(..), SimplifierMode(..), DynFlags, DynFlag(..), dopt, - dopt_CoreToDo, buildCoreToDo - ) + getCoreToDo ) import CoreSyn import TcIface ( loadImportedRules ) import HscTypes ( HscEnv(..), ModGuts(..), ExternalPackageState(..), @@ -71,9 +70,7 @@ core2core :: HscEnv core2core hsc_env guts = do let dflags = hsc_dflags hsc_env - core_todos - | Just todo <- dopt_CoreToDo dflags = todo - | otherwise = buildCoreToDo dflags + core_todos = getCoreToDo dflags us <- mkSplitUniqSupply 's' let (cp_us, ru_us) = splitUniqSupply us diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 5049a9f..ce0f442 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -61,7 +61,7 @@ import qualified Type ( substTy, substTyVarBndr ) import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst, isUnLiftedType, seqType, tyVarsOfType ) import BasicTypes ( OccInfo(..), isFragileOcc ) -import CmdLineOpts ( SimplifierMode(..) ) +import DynFlags ( SimplifierMode(..) ) import Outputable \end{code} diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 7d02906..b82562e 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -32,9 +32,8 @@ import Type ( Type ) import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply, UniqSupply ) -import CmdLineOpts ( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt, - opt_PprStyle_Debug, opt_HistorySize, - ) +import DynFlags ( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt ) +import StaticFlags ( opt_PprStyle_Debug, opt_HistorySize ) import OccName ( EncodedFS ) import Unique ( Unique ) import Maybes ( expectJust ) diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 827f5f47..105c521 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -23,9 +23,11 @@ module SimplUtils ( #include "HsVersions.h" import SimplEnv -import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..), opt_UF_UpdateInPlace, - opt_SimplNoPreInlining, opt_RulesOff, +import DynFlags ( SimplifierSwitch(..), SimplifierMode(..), DynFlag(..), dopt ) +import StaticFlags ( opt_UF_UpdateInPlace, opt_SimplNoPreInlining, + opt_RulesOff ) + import CoreSyn import CoreFVs ( exprFreeVars ) import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 06af5ad..1f88c60 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -8,7 +8,7 @@ module Simplify ( simplTopBinds, simplExpr ) where #include "HsVersions.h" -import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings), +import DynFlags ( dopt, DynFlag(Opt_D_dump_inlinings), SimplifierSwitch(..) ) import SimplMonad diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index bdb8c76..36b47d8 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -16,9 +16,8 @@ import StgLint ( lintStgBindings ) import StgStats ( showStgStats ) import SRT ( computeSRTs ) -import CmdLineOpts ( DynFlags, DynFlag(..), dopt, - StgToDo(..), dopt_StgToDo - ) +import DynFlags ( DynFlags(..), DynFlag(..), dopt, StgToDo(..), + getStgToDo ) import Id ( Id ) import Module ( Module ) import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn, showPass ) @@ -44,8 +43,7 @@ stg2stg dflags module_name binds -- Do the main business! ; (processed_binds, _, cost_centres) - <- foldl_mn do_stg_pass (binds', us', ccs) - (dopt_StgToDo dflags) + <- foldl_mn do_stg_pass (binds', us', ccs) (getStgToDo dflags) ; let srt_binds = computeSRTs processed_binds diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs index eb51686..b5f3f0e 100644 --- a/ghc/compiler/specialise/SpecConstr.lhs +++ b/ghc/compiler/specialise/SpecConstr.lhs @@ -28,7 +28,7 @@ import Name ( nameOccName, nameSrcLoc ) import Rules ( addIdSpecialisations ) import OccName ( mkSpecOcc ) import ErrUtils ( dumpIfSet_dyn ) -import CmdLineOpts ( DynFlags, DynFlag(..) ) +import DynFlags ( DynFlags, DynFlag(..) ) import BasicTypes ( Activation(..) ) import Outputable diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 980db08..c5d5d73 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -8,7 +8,7 @@ module Specialise ( specProgram ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..) ) +import DynFlags ( DynFlags, DynFlag(..) ) import Id ( Id, idName, idType, mkUserLocal ) import TcType ( Type, mkTyVarTy, tcSplitSigmaTy, tyVarsOfTypes, tyVarsOfTheta, isClassPred, diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index e351ea4..8a97d51 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -32,7 +32,8 @@ import Maybes ( maybeToBool ) import Name ( getOccName, isExternalName, nameOccName ) import OccName ( occNameUserString, occNameFS ) import BasicTypes ( Arity ) -import CmdLineOpts ( DynFlags, opt_RuntimeTypes ) +import DynFlags ( DynFlags ) +import StaticFlags ( opt_RuntimeTypes ) import Outputable infixr 9 `thenLne` diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 9c1c546..2e2db8c 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -65,7 +65,8 @@ import TyCon ( TyCon ) import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet ) import Unique ( Unique ) import Bitmap -import CmdLineOpts ( DynFlags, opt_SccProfilingOn ) +import DynFlags ( DynFlags ) +import StaticFlags ( opt_SccProfilingOn ) \end{code} %************************************************************************ diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs index 8928b20..9ac5e38 100644 --- a/ghc/compiler/stranal/DmdAnal.lhs +++ b/ghc/compiler/stranal/DmdAnal.lhs @@ -13,7 +13,8 @@ module DmdAnal ( dmdAnalPgm, dmdAnalTopRhs, #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..), opt_MaxWorkerArgs ) +import DynFlags ( DynFlags, DynFlag(..) ) +import StaticFlags ( opt_MaxWorkerArgs ) import NewDemand -- All of it import CoreSyn import PprCore diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index 3cd9ba4..a6a79ec 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -20,7 +20,7 @@ module SaAbsInt ( #include "HsVersions.h" -import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict ) +import StaticFlags ( opt_AllStrict, opt_NumbersStrict ) import CoreSyn import CoreUnfold ( maybeUnfoldingTemplate ) import Id ( Id, idType, idUnfolding, isDataConWorkId_maybe, diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index d143a15..242a947 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -16,7 +16,7 @@ module StrictAnal ( saBinds ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..) ) +import DynFlags ( DynFlags, DynFlag(..) ) import CoreSyn import Id ( setIdStrictness, setInlinePragma, idDemandInfo, setIdDemandInfo, isBottomingId, diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index f407691..28a465b 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -29,7 +29,7 @@ import Unique ( hasKey ) import BasicTypes ( RecFlag(..), isNonRec, Activation(..) ) import VarEnv ( isEmptyVarEnv ) import Maybes ( orElse ) -import CmdLineOpts +import DynFlags import WwLib import Util ( lengthIs, notNull ) import Outputable diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 3d3ea8b..c71a738 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -88,7 +88,7 @@ import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rational import BasicTypes( IPName(..), mapIPName, ipNameName ) import UniqSupply( uniqsFromSupply ) import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) ) -import CmdLineOpts( DynFlags ) +import DynFlags( DynFlags ) import Maybes ( isJust ) import Outputable \end{code} diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 21ba248..4107d30 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -11,7 +11,7 @@ module TcBinds ( tcBindsAndThen, tcTopBinds, tcHsBootSigs, tcMonoBinds, tcSpecSi import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho ) -import CmdLineOpts ( DynFlag(Opt_MonomorphismRestriction) ) +import DynFlags ( DynFlag(Opt_MonomorphismRestriction) ) import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, Sig(..), LSig, Match(..), HsBindGroup(..), IPBind(..), HsType(..), HsExplicitForAll(..), hsLTyVarNames, isVanillaLSig, diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index a1015f0..ed211b3 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -52,7 +52,7 @@ import OccName ( reportIfUnused, mkDefaultMethodOcc ) import RdrName ( RdrName, mkDerivedRdrName ) import Outputable import PrelNames ( genericTyConNames ) -import CmdLineOpts +import DynFlags import UnicodeUtil ( stringToUtf8 ) import ErrUtils ( dumpIfSet_dyn ) import Util ( count, lengthIs, isSingleton, lengthExceeds ) diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 45bca4c..703d3a8 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -11,7 +11,7 @@ module TcDeriv ( tcDeriving ) where #include "HsVersions.h" import HsSyn -import CmdLineOpts ( DynFlag(..) ) +import DynFlags ( DynFlag(..) ) import Generics ( mkTyConGenericBinds ) import TcRnMonad diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index a67d30e..0c9d7c2 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -57,7 +57,8 @@ import PrelNames ( enumFromName, enumFromThenName, enumFromToPName, enumFromThenToPName ) import ListSetOps ( minusList ) -import CmdLineOpts +import DynFlags +import StaticFlags ( opt_NoMethodSharing ) import HscTypes ( TyThing(..) ) import SrcLoc ( Located(..), unLoc, getLoc ) import Util diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 04cff32..6b18d07 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -46,7 +46,7 @@ import ForeignCall ( CExportSpec(..), CCallTarget(..), CLabelString, isCLabelString, isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) import PrelNames ( hasKey, ioTyConKey ) -import CmdLineOpts ( dopt_HscTarget, HscTarget(..) ) +import DynFlags ( DynFlags(..), HscTarget(..) ) import Outputable import SrcLoc ( Located(..), srcSpanStart ) import Bag ( consBag ) @@ -315,11 +315,11 @@ checkCOrAsmOrDotNetOrInterp other checkCg check = getDOpts `thenM` \ dflags -> - let hscTarget = dopt_HscTarget dflags in - case hscTarget of + let target = hscTarget dflags in + case target of HscNothing -> returnM () otherwise -> - case check hscTarget of + case check target of Nothing -> returnM () Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) \end{code} diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index b4a0ac7..49da076 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -80,7 +80,7 @@ import FunDeps ( grow ) import Name ( Name, setNameUnique, mkSysTvName ) import VarSet import VarEnv -import CmdLineOpts ( dopt, DynFlag(..) ) +import DynFlags ( dopt, DynFlag(..) ) import UniqSupply ( uniqsFromSupply ) import Util ( nOfThem, isSingleton, equalLength, notNull ) import ListSetOps ( removeDups ) diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 208af13..a6d9d1d 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -36,7 +36,7 @@ import TcHsType ( UserTypeCtxt(..), TcSigInfo( sig_tau ), TcSigFun, tcHsPatSigT import TysWiredIn ( stringTy, parrTyCon, tupleTyCon ) import Unify ( MaybeErr(..), gadtRefineTys, BindFlag(..) ) import Type ( substTys, substTheta ) -import CmdLineOpts ( opt_IrrefutableTuples ) +import StaticFlags ( opt_IrrefutableTuples ) import TyCon ( TyCon ) import DataCon ( DataCon, dataConTyCon, isVanillaDataCon, dataConInstOrigArgTys, dataConFieldLabels, dataConSourceArity, dataConSig ) diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 84c8ec4..9fb7177 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -22,10 +22,10 @@ import IO import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) #endif -import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) +import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) ) +import StaticFlags ( opt_PprStyle_Debug ) import Packages ( moduleToPackageConfig, mkPackageId, package, isHomeModule ) -import DriverState ( v_MainModIs, v_MainFunIs ) import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..), nlHsApp, nlHsVar, pprLHsBinds ) import RdrHsSyn ( findSplice ) @@ -69,7 +69,7 @@ import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind ) import SrcLoc ( srcLocSpan, Located(..), noLoc ) import DriverPhases ( HscSource(..), isHsBoot ) import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..), - GhciMode(..), IsBootInterface, noDependencies, + IsBootInterface, noDependencies, Deprecs( NoDeprecs ), plusDeprecs, ForeignStubs(NoStubs), TyThing(..), TypeEnv, lookupTypeEnv, hptInstances, lookupType, @@ -699,13 +699,11 @@ tcTopSrcDecls boot_names checkMain = do { ghci_mode <- getGhciMode ; tcg_env <- getGblEnv ; - - mb_main_mod <- readMutVar v_MainModIs ; - mb_main_fn <- readMutVar v_MainFunIs ; - let { main_mod = case mb_main_mod of { + dflags <- getDOpts ; + let { main_mod = case mainModIs dflags of { Just mod -> mkModule mod ; Nothing -> mAIN } ; - main_fn = case mb_main_fn of { + main_fn = case mainFunIs dflags of { Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ; Nothing -> main_RDR_Unqual } } ; diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 374c9cc..9051e4d 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -15,7 +15,7 @@ import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), TyThing, TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot, ExternalPackageState(..), HomePackageTable, Deprecs(..), FixityEnv, FixItem, - GhciMode, lookupType, unQualInScope ) + lookupType, unQualInScope ) import Module ( Module, unitModuleEnv ) import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv ) @@ -37,7 +37,8 @@ import Bag ( emptyBag ) import Outputable import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply ) import Unique ( Unique ) -import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_PprStyle_Debug, dopt_set ) +import DynFlags ( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode ) +import StaticFlags ( opt_PprStyle_Debug ) import Bag ( snocBag, unionBags ) import Panic ( showException ) @@ -238,8 +239,8 @@ ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -- Do it flag is tru ifOptM flag thing_inside = do { b <- doptM flag; if b then thing_inside else return () } -getGhciMode :: TcRnIf gbl lcl GhciMode -getGhciMode = do { env <- getTopEnv; return (hsc_mode env) } +getGhciMode :: TcRnIf gbl lcl GhcMode +getGhciMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 0a433ec..180a99e 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -68,7 +68,8 @@ import ListSetOps ( equivClasses ) import Util ( zipEqual, isSingleton ) import List ( partition ) import SrcLoc ( Located(..) ) -import CmdLineOpts +import DynFlags ( DynFlag(..) ) +import StaticFlags \end{code} diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 3d951b7..b3b3de6 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -54,7 +54,8 @@ import List ( partition ) import SrcLoc ( Located(..), unLoc, getLoc ) import ListSetOps ( equivClasses ) import Digraph ( SCC(..) ) -import CmdLineOpts ( DynFlag( Opt_GlasgowExts, Opt_Generics, Opt_UnboxStrictFields ) ) +import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics, + Opt_UnboxStrictFields ) ) \end{code} diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index b9ff393..2c3a55b 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -164,7 +164,7 @@ import ForeignCall ( Safety, playSafe, DNType(..) ) import VarSet -- others: -import CmdLineOpts ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt ) +import DynFlags ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt ) import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc ) import NameSet import VarEnv ( TidyEnv ) diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index 965ba55..1be556b 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -29,7 +29,7 @@ import TyCon ( TyCon ) import Outputable import UniqFM ( UniqFM, lookupUFM, emptyUFM, addToUFM_C, eltsUFM ) import Id ( idType ) -import CmdLineOpts +import DynFlags import Util ( notNull ) import Maybe ( isJust ) \end{code} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index fe848d6..bf407e5 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -101,7 +101,7 @@ import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon, ) -- others -import CmdLineOpts ( opt_DictsStrict ) +import StaticFlags ( opt_DictsStrict ) import SrcLoc ( noSrcLoc ) import Unique ( Uniquable(..) ) import Util ( mapAccumL, seqList, lengthIs, snocView, thenCmp, isEqual ) diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 5a4368c..e0e9bbb 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -54,7 +54,7 @@ module Outputable ( import {-# SOURCE #-} Module( Module ) import {-# SOURCE #-} OccName( OccName ) -import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength ) +import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength ) import PackageConfig ( PackageId, packageIdString ) import FastString import qualified Pretty diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 11d1b5e..d3eb975 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -30,11 +30,12 @@ module Util ( mapAccumL, mapAccumR, mapAccumB, foldl2, count, - takeList, dropList, splitAtList, + takeList, dropList, splitAtList, split, -- comparisons isEqual, eqListBy, equalLength, compareLength, thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch, + removeSpaces, -- strictness foldl', seqList, @@ -42,7 +43,7 @@ module Util ( -- pairs unzipWith, - global, + global, consIORef, -- module names looksLikeModuleName, @@ -51,6 +52,21 @@ module Util ( -- Floating point stuff readRational, + + -- IO-ish utilities + createDirectoryHierarchy, + doesDirNameExist, + + later, handleDyn, handle, + + -- Filename utils + Suffix, + splitFilename, getFileSuffix, splitFilenameDir, + splitFilename3, removeSuffix, + dropLongestPrefix, takeLongestPrefix, splitLongestPrefix, + replaceFilenameSuffix, directoryOf, filenameOf, + replaceFilenameDirectory, + escapeSpaces, isPathSeparator, ) where #include "HsVersions.h" @@ -58,11 +74,12 @@ module Util ( import Panic ( panic, trace ) import FastTypes -#if __GLASGOW_HASKELL__ <= 408 -import EXCEPTION ( catchIO, justIoErrors, raiseInThread ) -#endif +import EXCEPTION ( Exception(..), finally, throwDyn, catchDyn, throw ) +import qualified EXCEPTION as Exception +import DYNAMIC ( Typeable ) import DATA_IOREF ( IORef, newIORef ) import UNSAFE_IO ( unsafePerformIO ) +import DATA_IOREF ( readIORef, writeIORef ) import qualified List ( elem, notElem ) @@ -70,6 +87,9 @@ import qualified List ( elem, notElem ) import List ( zipWith4 ) #endif +import Monad ( when ) +import IO ( catch ) +import Directory ( doesDirectoryExist, createDirectory ) import Char ( isUpper, isAlphaNum, isSpace, ord, isDigit ) import Ratio ( (%) ) @@ -571,6 +591,11 @@ splitAtList (_:xs) (y:ys) = (y:ys', ys'') where (ys', ys'') = splitAtList xs ys +split :: Char -> String -> [String] +split c s = case rest of + [] -> [chunk] + _:rest -> chunk : split c rest + where (chunk, rest) = break (==c) s \end{code} @@ -634,6 +659,9 @@ maybePrefixMatch (p:pat) (r:rest) suffixMatch :: Eq a => [a] -> [a] -> Bool suffixMatch pat str = prefixMatch (reverse pat) (reverse str) + +removeSpaces :: String -> String +removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace \end{code} %************************************************************************ @@ -685,6 +713,13 @@ global :: a -> IORef a global a = unsafePerformIO (newIORef a) \end{code} +\begin{code} +consIORef :: IORef [a] -> a -> IO () +consIORef var x = do + xs <- readIORef var + writeIORef var (x:xs) +\end{code} + Module names: \begin{code} @@ -768,4 +803,124 @@ readRational top_s [x] -> x [] -> error ("readRational: no parse:" ++ top_s) _ -> error ("readRational: ambiguous parse:" ++ top_s) + + +----------------------------------------------------------------------------- +-- Create a hierarchy of directories + +createDirectoryHierarchy :: FilePath -> IO () +createDirectoryHierarchy dir = do + b <- doesDirectoryExist dir + when (not b) $ do + createDirectoryHierarchy (directoryOf dir) + createDirectory dir + +----------------------------------------------------------------------------- +-- Verify that the 'dirname' portion of a FilePath exists. +-- +doesDirNameExist :: FilePath -> IO Bool +doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath) + +-- ----------------------------------------------------------------------------- +-- Exception utils + +later = flip finally + +handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a +handleDyn = flip catchDyn + +handle :: (Exception -> IO a) -> IO a -> IO a +#if __GLASGOW_HASKELL__ < 501 +handle = flip Exception.catchAllIO +#else +handle h f = f `Exception.catch` \e -> case e of + ExitException _ -> throw e + _ -> h e +#endif + +-- -------------------------------------------------------------- +-- Filename manipulation + +type Suffix = String + +splitFilename :: String -> (String,Suffix) +splitFilename f = splitLongestPrefix f (=='.') + +getFileSuffix :: String -> Suffix +getFileSuffix f = dropLongestPrefix f (=='.') + +-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext") +splitFilenameDir :: String -> (String,String) +splitFilenameDir str + = let (dir, rest) = splitLongestPrefix str isPathSeparator + real_dir | null dir = "." + | otherwise = dir + in (real_dir, rest) + +-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext") +splitFilename3 :: String -> (String,String,Suffix) +splitFilename3 str + = let (dir, rest) = splitLongestPrefix str isPathSeparator + (name, ext) = splitFilename rest + real_dir | null dir = "." + | otherwise = dir + in (real_dir, name, ext) + +removeSuffix :: Char -> String -> Suffix +removeSuffix c s + | null pre = s + | otherwise = reverse pre + where (suf,pre) = break (==c) (reverse s) + +dropLongestPrefix :: String -> (Char -> Bool) -> String +dropLongestPrefix s pred = reverse suf + where (suf,_pre) = break pred (reverse s) + +takeLongestPrefix :: String -> (Char -> Bool) -> String +takeLongestPrefix s pred = reverse pre + where (_suf,pre) = break pred (reverse s) + +-- split a string at the last character where 'pred' is True, +-- returning a pair of strings. The first component holds the string +-- up (but not including) the last character for which 'pred' returned +-- True, the second whatever comes after (but also not including the +-- last character). +-- +-- If 'pred' returns False for all characters in the string, the original +-- string is returned in the second component (and the first one is just +-- empty). +splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) +splitLongestPrefix s pred + = case pre of + [] -> ([], reverse suf) + (_:pre) -> (reverse pre, reverse suf) + where (suf,pre) = break pred (reverse s) + +replaceFilenameSuffix :: FilePath -> Suffix -> FilePath +replaceFilenameSuffix s suf = removeSuffix '.' s ++ suf + +-- directoryOf strips the filename off the input string, returning +-- the directory. +directoryOf :: FilePath -> String +directoryOf = fst . splitFilenameDir + +-- filenameOf strips the directory off the input string, returning +-- the filename. +filenameOf :: FilePath -> String +filenameOf = snd . splitFilenameDir + +replaceFilenameDirectory :: FilePath -> String -> FilePath +replaceFilenameDirectory s dir + = dir ++ '/':dropLongestPrefix s isPathSeparator + +escapeSpaces :: String -> String +escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) "" + +isPathSeparator :: Char -> Bool +isPathSeparator ch = +#ifdef mingw32_TARGET_OS + ch == '/' || ch == '\\' +#else + ch == '/' +#endif \end{code}