diff options
118 files changed, 3259 insertions, 3461 deletions
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 63ef83f955..f2c70c3c7b 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 4b58fd555d..8e68fd87d2 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 d3b9bcb693..a4579b4b15 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 feec598001..f9f2eadafa 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 b852eb3b48..3ae93ff6b1 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 824179c0f8..04c8194d1f 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 7be8b84982..9b73c3bcf7 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 82bdec31b8..fad78d8215 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 3c8066ba97..3c3d4e2494 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 1f25fafd42..572a3876f5 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 b0bdf46467..e154bed545 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 2183d89b77..940852d078 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 4ba8f093b3..4160580f92 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 74cbeb5fda..b826a33cba 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 f43982d4c1..aa654fd425 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 19dbc43aac..3e72981c50 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 c8cae4b6cf..643c4917b8 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 dbd4314e16..a0b18ebc99 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 608ff92671..fa92421b21 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 8bbf79d1da..1ffbcda56d 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 7467e47a02..79735bcbee 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 60ddc5cb9b..fbf4927dfd 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 d7d2a999fc..f918d721f7 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 0a2bd0d9d1..eb790d1693 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 3327e8bb0a..0cb191875d 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 b07d917777..f7383191d9 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 d148b2baaf..e101a7870f 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 a41e62fb6c..8ca265f5b3 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 be26463f49..c8a51514f0 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 369660a939..70e5d16f73 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 1f20f59f1f..6192d5a4c2 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 b82a30a7bc..552526bec3 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 43471d8f85..3d95b713d0 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 5f9fe00305..99e9e11f85 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 143fb6afd9..b812354bf3 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 7df178d0f3..d87c2bbd25 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 6994a21dd0..0feb26b84d 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 03d414a0e5..257b940c8e 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 b809e3a9a7..11e62389af 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 a760b83bfd..25d05081a5 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 354e31e405..c21a9adb64 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 a75582aa51..a2cfbed1f6 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 8d6c915cdd..66d9b0246c 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 cf7fd7f3f2..0000000000 --- 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 0000000000..dd22348bd7 --- /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 b01b6680a2..704a908d08 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 f0f60f7694..0000000000 --- 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-<blah>" options cancel out "-f<blah>" on the hsc cmdline - , ( "fno-", PrefixPred (\s -> isStaticHscFlag ("f"++s)) - (\s -> add v_Anti_opt_C ("-f"++s)) ) - - -- Pass all remaining "-f<blah>" 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<blah>) 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<blah> flags can all be reversed with -fno-<blah> - -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<n>)") - -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 a4c02338b5..3837d2cbdf 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 a1c3309bc6..693c4e17c9 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 1856dce60a..9ffc9db444 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-<blah> (including -l<blah> 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-<blah> - 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 392ed14098..0000000000 --- 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 "<Drive>:/" 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 094113657e..0000000000 --- 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 0000000000..62d269d1ba --- /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<blah>) 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<blah> flags can all be reversed with -fno-<blah> + +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<n>)") + +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 + -- "<Drive>:/" 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 7b7dcf8afb..434b7d77d6 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 a260f3e7ca..97904a1093 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 6c9f9ef166..c165b4a58a 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 81015ac9ec..8570044ad8 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 5119a78f06..dd4f003fff 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 bb128f26e4..f31113007d 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<size> ----------------------------------------------------------------------------- --- 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 bc83440dc8..ac26a9ab6f 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 3aae806d18..6d3f0df333 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 0000000000..0bce0d19eb --- /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-<blah>" options cancel out "-f<blah>" on the hsc cmdline + , ( "fno-", PrefixPred (\s -> isStaticFlag ("f"++s)) + (\s -> removeOpt ("-f"++s)) ) + + -- Pass all remaining "-f<blah>" 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 738e63f4c7..9710bcb96c 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 ee4b5bbda5..73ef49d5d9 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 5844c89e08..2a7492b858 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 20aad786b8..9e7787c73e 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 936b76afcb..a874270b19 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 0f33ca3929..26b192fad9 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 4f71fe1edb..7c5a4bdbb9 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 b6e91e517b..306797166c 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 cd4bdd447f..3fc1d5565e 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 30719ce1e9..57eec1618d 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 0a2f3c5e23..89d288abfe 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 9378f768db..8b855517e1 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 3a3c02cfe9..04b24c3b12 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 97aedf223f..8c6bcf9052 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 291a65e4d8..94ae27f913 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 09bb3bcad0..a5808844f3 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 2281f3e74b..64f0370b0b 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 686f01d4fd..2b43899235 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 48838eef3c..653f3125ea 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 15e74d0ec8..661f0c4aec 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 14febd6416..2e8489a295 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 0ca2257189..ae6ce75dab 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 e3b877e975..a53d0c6932 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 20c012d18c..c29a5b9c68 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 d8d4ff0e75..8f7c98c0f4 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 14214467f0..d785cdcbc2 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 5049a9fdc9..ce0f442512 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 7d02906a8c..b82562e668 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 827f5f4730..105c5210cd 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 06af5ad251..1f88c60b3f 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 bdb8c761c8..36b47d8dd8 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 eb516869b0..b5f3f0eebe 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 980db0822c..c5d5d73d37 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 e351ea4a27..8a97d51542 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 9c1c5466c2..2e2db8c164 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 8928b20b7a..9ac5e38c00 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 3cd9ba434b..a6a79ec166 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 d143a15b86..242a947074 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 f407691db9..28a465b239 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 3d3ea8bf7f..c71a738de5 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 21ba2483ca..4107d307ff 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 a1015f0b7d..ed211b362c 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 45bca4c600..703d3a840a 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 a67d30e9d3..0c9d7c2f4a 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 04cff32ecd..6b18d075df 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 b4a0ac739c..49da076fba 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 208af13cc0..a6d9d1d7fc 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 84c8ec4c9d..9fb7177dae 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 374c9ccb6f..9051e4dfe9 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 0a433ec88d..180a99e7c1 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 3d951b7858..b3b3de66f0 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 b9ff393b60..2c3a55b6ac 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 965ba55e55..1be556b221 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 fe848d6450..bf407e57e0 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 5a4368c09a..e0e9bbb672 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 11d1b5e545..d3eb975694 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} |