Flags cleanup.
Basically the purpose of this commit is to move more of the compiler's
global state into DynFlags, which is moving in the direction we need
to go for the GHC API which can have multiple active sessions
supported by a single GHC instance.
Before:
$ grep 'global_var' */*hs | wc -l
78
After:
$ grep 'global_var' */*hs | wc -l
27
Well, it's an improvement. Most of what's left won't really affect
our ability to host multiple sessions.
Lots of static flags have become dynamic flags (yay!). Notably lots
of flags that we used to think of as "driver" flags, like -I and -L,
are now dynamic. The most notable static flags left behind are the
"way" flags, eg. -prof. It would be nice to fix this, but it isn't
urgent.
On the way, lots of cleanup has happened. Everything related to
static and dynamic flags lives in StaticFlags and DynFlags
respectively, and they share a common command-line parser library in
CmdLineParser. The flags related to modes (--makde, --interactive
etc.) are now private to the front end: in fact private to Main
itself, for now.
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`,
#include "HsVersions.h"
-import CmdLineOpts ( opt_CprOff )
+import StaticFlags ( opt_CprOff )
import BasicTypes ( Arity )
import VarEnv ( VarEnv, emptyVarEnv, isEmptyVarEnv )
import UniqFM ( ufmToList )
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}
#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 )
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
import FastString
import Outputable
import Constants
-import CmdLineOpts ( opt_EnsureSplittableC )
+import StaticFlags ( opt_SplitObjs )
-- The rest
import Data.List ( intersperse, groupBy )
-- 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
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
%
% (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 $
%
%********************************************************
%* *
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 )
%
% (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}
mkLblExpr )
import CLabel
import StgSyn
-import CmdLineOpts ( opt_DoTickyProfiling )
+import StaticFlags ( opt_DoTickyProfiling )
import CostCentre
import Id ( Id, idName, idType )
import Name ( Name )
import SMRep
import ForeignCall
import Constants
-import CmdLineOpts ( opt_SccProfilingOn )
+import StaticFlags ( opt_SccProfilingOn )
import Outputable
import Monad ( when )
%
% (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}
import CostCentre ( CostCentreStack )
import Util ( mapAccumL, filterOut )
import Constants ( wORD_SIZE )
-import CmdLineOpts ( DynFlags )
+import DynFlags ( DynFlags )
import Outputable
import GLAEXTS
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 )
%
% (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}
import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
-import CmdLineOpts ( DynFlags )
+import DynFlags ( DynFlags )
import Cmm
import CmmUtils ( CmmStmts, isNopStmt )
import CLabel
import CgCallConv ( mkRegLiveness )
import Id ( Id )
import Cmm ( CmmLit, GlobalReg(..), node, CmmExpr )
-import CmdLineOpts ( opt_GranMacros )
+import StaticFlags ( opt_GranMacros )
import Outputable
staticParHdr :: [CmmLit]
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
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
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
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 )
#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.
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 )
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
\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
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
CmState, -- Abstract
- cmInit, -- :: GhciMode -> IO CmState
+ cmInit, -- :: GhcMode -> IO CmState
cmDepAnal, -- :: CmState -> [FilePath] -> IO ModuleGraph
cmDownsweep,
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 )
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 )
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 )
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 })}
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
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))]))
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
= 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
-- 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
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" ++
-- 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
getValidLinkablesSCC
- :: GhciMode
+ :: GhcMode
-> [Linkable] -- old linkables
-> [Module] -- all home modules
-> [(Linkable,Bool)]
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'
(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
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
import Maybes
import OrdList
import ErrUtils
-import CmdLineOpts
+import DynFlags
import Util ( listLengthCmp )
import Outputable
\end{code}
#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 )
#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 )
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,
import Name
import Outputable
import ForeignCall
-import CmdLineOpts
+import DynFlags ( DynFlags(..) )
+import StaticFlags ( opt_EmitExternalCore )
import Maybes ( mapCatMaybes )
import IO
import FastString
#include "HsVersions.h"
-import CmdLineOpts ( DynFlags, DynFlag(..) )
+import DynFlags ( DynFlags, DynFlag(..) )
import CoreLint ( showPass, endPass )
import CoreSyn
import CoreUtils ( exprIsValue )
#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(..) )
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
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
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 )
import Name ( Name, nameOccName )
import NameEnv
import OccName ( occNameFS )
-import CmdLineOpts ( DynFlags )
+import DynFlags ( DynFlags )
import ErrUtils ( WarnMsg, mkWarnMsg )
import Bag ( mapBag )
#include "HsVersions.h"
-import CmdLineOpts ( DynFlag(..), dopt )
+import DynFlags ( DynFlag(..), dopt )
import HsSyn
import TcHsSyn ( hsPatType )
import Check ( check, ExhaustivePat )
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 )
{-# 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
--
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)
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 )
import NameSet ( nameSetToList )
import Module
import ListSetOps ( minusList )
-import CmdLineOpts ( DynFlags(..) )
+import DynFlags ( DynFlags(..) )
import BasicTypes ( SuccessFlag(..), succeeded, failed )
import Outputable
import Panic ( GhcException(..) )
import Foreign.C
import Foreign ( Ptr, nullPtr )
import Panic ( panic )
-import DriverUtil ( prefixUnderscore )
import BasicTypes ( SuccessFlag, successIf )
import Outputable
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
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}
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
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(..),
-- 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;
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,
)
-import CmdLineOpts
+import DynFlags ( GhcMode(..), DynFlags(..), DynFlag(..), dopt )
+import StaticFlags ( opt_HiVersion )
import Name ( Name, nameModule, nameOccName, nameParent,
isExternalName, nameParent_maybe, isWiredInName,
NamedThing(..) )
extendModuleEnv_C
)
import Outputable
-import DriverUtil ( createDirectoryHierarchy, directoryOf )
+import Util ( createDirectoryHierarchy, directoryOf )
import Util ( sortLe, seqList )
import Binary ( getBinFileWithDict )
import BinIface ( writeBinIface, v_IgnoreHiWay )
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
import Maybes ( MaybeErr(..) )
import SrcLoc ( noSrcLoc )
import Util ( zipWithEqual, dropList, equalLength )
-import CmdLineOpts ( DynFlag(..) )
+import DynFlags ( DynFlag(..) )
\end{code}
This module takes
-- 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 )
+++ /dev/null
-
-% (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}
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- 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)
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 )
}
; 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
+++ /dev/null
------------------------------------------------------------------------------
---
--- 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
-----------------------------------------------------------------------------
--- $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
--
-----------------------------------------------------------------------------
#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
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
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.
-- 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) )
]
-----------------------------------------------------------------------------
--- $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
--
module DriverPhases (
HscSource(..), isHsBoot, hscSourceString,
- HscTarget(..), Phase(..),
+ Phase(..),
happensBefore, eqPhase, anyHsc, isStopLn,
startPhase, -- :: String -> Phase
phaseInputExt, -- :: Phase -> String
isSourceFilename -- :: FilePath -> Bool
) where
-import DriverUtil
+import Util ( getFileSuffix )
import Panic ( panic )
-----------------------------------------------------------------------------
isHsBoot HsBootFile = True
isHsBoot other = False
-data HscTarget
- = HscC
- | HscAsm
- | HscJava
- | HscILX
- | HscInterpreted
- | HscNothing
- deriving (Eq, Show)
-
data Phase
= Unlit HscSource
| Cpp HscSource
| 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
-----------------------------------------------------------------------------
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,
import Packages
import GetImports
-import DriverState
-import DriverUtil
import DriverPhases
-import DriverFlags
import SysTools ( newTempName, addFilesToClean, getSysMan, copy )
import qualified SysTools
import HscMain
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
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
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
-- ---------------------------------------------------------------------------
--- 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.
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)
-- 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
-- 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
| 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 ]
_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
| 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
-- ---------------------------------------------------------------------------
-- Link
-link :: GhciMode -- interactive or batch
+link :: GhcMode -- interactive or batch
-> DynFlags -- dynamic flags
-> Bool -- attempt linking in batch mode?
-> HomePackageTable -- what to link
return Succeeded
#endif
-link Batch dflags batch_attempt_linking hpt
+link BatchCompile dflags batch_attempt_linking hpt
| batch_attempt_linking
= do
let
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
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
-> 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
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...
; 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
| Just d <- odir = replaceFilenameDirectory persistent d
| otherwise = persistent
- return func
-
-- -----------------------------------------------------------------------------
-- Each phase in the pipeline returns the next phase to execute, and the
-- 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)
-- 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
, 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)
-- 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
-- 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) <-
-- 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
-- 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
-- (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
-- 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
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,
hscStubHOutName = basename ++ "_stub.h",
extCoreName = basename ++ ".hcr" }
- hsc_env <- newHscEnv OneShot dflags'
+ hsc_env <- newHscEnv dflags'
-- run the compiler!
result <- hscMain hsc_env printErrorsAndWarnings
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
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,
= 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 []
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
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
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
(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"
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
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
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
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
]
| otherwise = []
- (md_c_flags, _) <- machdepCCOpts dflags
+ let (md_c_flags, _) = machdepCCOpts dflags
SysTools.runLink dflags (
[ SysTools.Option verb
, SysTools.Option "-o"
))
-- 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")))
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
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
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"
))
-- -----------------------------------------------------------------------------
--- 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) []
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)
, 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
| 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
+++ /dev/null
------------------------------------------------------------------------------
---
--- 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
+++ /dev/null
------------------------------------------------------------------------------
--- $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
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- 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
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 )
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 )
-- 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.
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
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.
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)
-- -----------------------------------------------------------------------------
-- 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
-- | 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)
import StringBuffer ( StringBuffer, hGetStringBuffer )
import SrcLoc ( Located(..), mkSrcLoc, unLoc )
import FastString ( mkFastString )
-import CmdLineOpts ( DynFlags )
+import DynFlags ( DynFlags )
import ErrUtils
import Pretty
import Panic
import CmmParse ( parseCmmFile )
import CodeOutput ( codeOutput )
-import CmdLineOpts
+import DynFlags
import DriverPhases ( HscSource(..) )
import ErrUtils
import UniqSupply ( mkSplitUniqSupply )
%************************************************************************
\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 } ) }
-- 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";
-------------------
-- 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)
= 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
-------------------
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 ->
\begin{code}
module HscTypes (
HscEnv(..), hscEPS,
- GhciMode(..), isOneShot,
ModDetails(..),
ModGuts(..), ModImports(..), ForeignStubs(..),
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 )
\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
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
-- 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
{-# 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
--
-----------------------------------------------------------------------------
#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
-----------------------------------------------------------------------------
-- 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
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
{-
-- 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 ()
= 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.
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
# 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))
#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 )
++ '-':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
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
import PackageConfig
import Lexer
-import CmdLineOpts
+import DynFlags
import FastString
import StringBuffer
import ErrUtils ( mkLocMessage )
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- 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" ]
-- 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)
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 ()
#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 )
(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
\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
; 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,
-- 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)
#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
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
\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 ()
-- ToDo: speed up via slurping.
hPutStr h ls
hClose h
+
\end{code}
\begin{code}
= 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
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
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
; 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
#include "HsVersions.h"
-import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
+import DynFlags ( DynFlags, DynFlag(..), dopt )
import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding )
import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars )
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
where
add_split (Cmm tops)
- | opt_EnsureSplittableC = split_marker : tops
- | otherwise = tops
+ | opt_SplitObjs = split_marker : tops
+ | otherwise = tops
split_marker = CmmProc [] mkSplitMarkerLabel [] []
import CLabel
-- The rest:
-import CmdLineOpts ( opt_PIC )
+import StaticFlags ( opt_PIC )
import ForeignCall ( CCallConv(..) )
import OrdList
import Pretty
import MachInstrs
import NCGMonad ( NatM, getNewRegNat, getNewLabelNat )
-import CmdLineOpts ( opt_PIC, opt_Static )
+import StaticFlags ( opt_PIC, opt_Static )
import Pretty
import qualified Outputable
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
-}
+{-
+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
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)
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)
exposed: True
exposed-modules:
- BasicTypes,\r
- DataCon,\r
- Demand,\r
- FieldLabel,\r
- Id,\r
- IdInfo,\r
- Literal,\r
- MkId,\r
- Module,\r
- Name,\r
- NameEnv,\r
- NameSet,\r
- NewDemand,\r
- OccName,\r
- RdrName,\r
- SrcLoc,\r
- UniqSupply,\r
- Unique,\r
- Var,\r
- VarEnv,\r
- VarSet,\r
- CLabel,\r
- Cmm,\r
- CmmLex,\r
- CmmLint,\r
- CmmParse,\r
- CmmUtils,\r
- MachOp,\r
- PprC,\r
- PprCmm,\r
- Bitmap,\r
- CgBindery,\r
- CgCallConv,\r
- CgCase,\r
- CgClosure,\r
- CgCon,\r
- CgExpr,\r
- CgForeignCall,\r
- CgHeapery,\r
- CgInfoTbls,\r
- CgLetNoEscape,\r
- CgMonad,\r
- CgParallel,\r
- CgPrimOp,\r
- CgProf,\r
- CgStackery,\r
- CgTailCall,\r
- CgTicky,\r
- CgUtils,\r
- ClosureInfo,\r
- CodeGen,\r
- SMRep,\r
- CompManager,\r
- CoreFVs,\r
- CoreLint,\r
- CorePrep,\r
- CoreSubst,\r
- CoreSyn,\r
- CoreTidy,\r
- CoreUnfold,\r
- CoreUtils,\r
- ExternalCore,\r
- MkExternalCore,\r
- PprCore,\r
- PprExternalCore,\r
- CprAnalyse,\r
- Check,\r
- Desugar,\r
- DsArrows,\r
- DsBinds,\r
- DsCCall,\r
- DsExpr,\r
- DsForeign,\r
- DsGRHSs,\r
- DsListComp,\r
- DsMeta,\r
- DsMonad,\r
- DsUtils,\r
- Match,\r
- MatchCon,\r
- MatchLit,\r
- ByteCodeAsm,\r
- ByteCodeFFI,\r
- ByteCodeGen,\r
- ByteCodeInstr,\r
- ByteCodeItbls,\r
- ByteCodeLink,\r
- InteractiveUI,\r
- Linker,\r
- ObjLink,\r
- Convert,\r
- HsBinds,\r
- HsDecls,\r
- HsExpr,\r
- HsImpExp,\r
- HsLit,\r
- HsPat,\r
- HsSyn,\r
- HsTypes,\r
- HsUtils,\r
- BinIface,\r
- BuildTyCl,\r
- IfaceEnv,\r
- IfaceSyn,\r
- IfaceType,\r
- LoadIface,\r
- MkIface,\r
- TcIface,\r
- IlxGen,\r
- Java,\r
- JavaGen,\r
- PrintJava,\r
- CmdLineOpts,\r
- CodeOutput,\r
- Config,\r
- Constants,\r
- DriverFlags,\r
- DriverMkDepend,\r
- DriverPhases,\r
- DriverPipeline,\r
- DriverState,\r
- DriverUtil,\r
- ErrUtils,\r
- Finder,\r
- GetImports,\r
- HscMain,\r
- HscStats,\r
- HscTypes,\r
- PackageConfig,\r
- Packages,\r
- ParsePkgConf,\r
- SysTools,\r
- TidyPgm,\r
- AsmCodeGen,\r
- MachCodeGen,\r
- MachInstrs,\r
- MachRegs,\r
- NCGMonad,\r
- PositionIndependentCode,\r
- PprMach,\r
- RegAllocInfo,\r
- RegisterAlloc,\r
- FlattenInfo,\r
- Flattening,\r
- FlattenMonad,\r
- NDPCoreUtils,\r
- PArrAnal,\r
- Ctype,\r
- LexCore,\r
- Lexer,\r
- Parser,\r
- ParserCore,\r
- ParserCoreUtils,\r
- RdrHsSyn,\r
- ForeignCall,\r
- PrelInfo,\r
- PrelNames,\r
- PrelRules,\r
- PrimOp,\r
- TysPrim,\r
- TysWiredIn,\r
- CostCentre,\r
- SCCfinal,\r
- RnBinds,\r
- RnEnv,\r
- RnExpr,\r
- RnHsSyn,\r
- RnNames,\r
- RnSource,\r
- RnTypes,\r
- CSE,\r
- FloatIn,\r
- FloatOut,\r
- LiberateCase,\r
- OccurAnal,\r
- SAT,\r
- SATMonad,\r
- SetLevels,\r
- SimplCore,\r
- SimplEnv,\r
- Simplify,\r
- SimplMonad,\r
- SimplUtils,\r
- SimplStg,\r
- SRT,\r
- StgStats,\r
- Rules,\r
- SpecConstr,\r
- Specialise,\r
- CoreToStg,\r
- StgLint,\r
- StgSyn,\r
- DmdAnal,\r
- SaAbsInt,\r
- SaLib,\r
- StrictAnal,\r
- WorkWrap,\r
- WwLib,\r
- Inst,\r
- TcArrows,\r
- TcBinds,\r
- TcClassDcl,\r
- TcDefaults,\r
- TcDeriv,\r
- TcEnv,\r
- TcExpr,\r
- TcForeign,\r
- TcGenDeriv,\r
- TcHsSyn,\r
- TcHsType,\r
- TcInstDcls,\r
- TcMatches,\r
- TcMType,\r
- TcPat,\r
- TcRnDriver,\r
- TcRnMonad,\r
- TcRnTypes,\r
- TcRules,\r
- TcSimplify,\r
- TcSplice,\r
- TcTyClsDecls,\r
- TcTyDecls,\r
- TcType,\r
- TcUnify,\r
- Class,\r
- FunDeps,\r
- Generics,\r
- InstEnv,\r
- Kind,\r
- TyCon,\r
- Type,\r
- TypeRep,\r
- Unify,\r
- Bag,\r
- Binary,\r
- BitSet,\r
- Digraph,\r
- FastMutInt,\r
- FastString,\r
- FastTypes,\r
- FiniteMap,\r
- IOEnv,\r
- ListSetOps,\r
- Maybes,\r
- OrdList,\r
- Outputable,\r
- Panic,\r
- Pretty,\r
- PrimPacked,\r
- StringBuffer,\r
- UnicodeUtil,\r
- UniqFM,\r
- UniqSet,\r
- Util\r
+ 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"
import FastTypes
import SrcLoc
import UniqFM
-import CmdLineOpts
+import DynFlags
import Ctype
import Util ( maybePrefixMatch, readRational )
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(..) )
import Name ( Name )
import Outputable
import FastString
-import CmdLineOpts ( opt_SimplExcessPrecision )
+import StaticFlags ( opt_SimplExcessPrecision )
import DATA_BITS ( Bits(..) )
#if __GLASGOW_HASKELL__ >= 500
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 )
bindLocalFixities, bindSigTyVarsFV,
warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
)
-import CmdLineOpts ( DynFlag(..) )
+import DynFlags ( DynFlag(..) )
import Digraph ( SCC(..), stronglyConnComp )
import Name ( Name, nameOccName, nameSrcLoc )
import NameSet
import Util ( sortLe )
import ListSetOps ( removeDups )
import List ( nubBy )
-import CmdLineOpts
+import DynFlags
\end{code}
%*********************************************************
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,
#include "HsVersions.h"
-import CmdLineOpts ( DynFlag(..) )
+import DynFlags ( DynFlag(..), GhcMode(..) )
import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl,
ForeignDecl(..), HsGroup(..), HsBindGroup(..),
Sig(..), collectGroupBinders, tyClDeclNames
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(..),
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}
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 )
#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 )
#include "HsVersions.h"
-import CmdLineOpts ( DynFlags, DynFlag(..) )
+import DynFlags ( DynFlags, DynFlag(..) )
import CoreSyn
import CoreUtils ( exprIsValue, exprIsDupable )
import CoreLint ( showPass, endPass )
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 )
#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 )
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,
#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(..),
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
import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst,
isUnLiftedType, seqType, tyVarsOfType )
import BasicTypes ( OccInfo(..), isFragileOcc )
-import CmdLineOpts ( SimplifierMode(..) )
+import DynFlags ( SimplifierMode(..) )
import Outputable
\end{code}
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 )
#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,
#include "HsVersions.h"
-import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings),
+import DynFlags ( dopt, DynFlag(Opt_D_dump_inlinings),
SimplifierSwitch(..)
)
import SimplMonad
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 )
-- 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
import Rules ( addIdSpecialisations )
import OccName ( mkSpecOcc )
import ErrUtils ( dumpIfSet_dyn )
-import CmdLineOpts ( DynFlags, DynFlag(..) )
+import DynFlags ( DynFlags, DynFlag(..) )
import BasicTypes ( Activation(..) )
import Outputable
#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,
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`
import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
import Unique ( Unique )
import Bitmap
-import CmdLineOpts ( DynFlags, opt_SccProfilingOn )
+import DynFlags ( DynFlags )
+import StaticFlags ( opt_SccProfilingOn )
\end{code}
%************************************************************************
#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
#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,
#include "HsVersions.h"
-import CmdLineOpts ( DynFlags, DynFlag(..) )
+import DynFlags ( DynFlags, DynFlag(..) )
import CoreSyn
import Id ( setIdStrictness, setInlinePragma,
idDemandInfo, setIdDemandInfo, isBottomingId,
import BasicTypes ( RecFlag(..), isNonRec, Activation(..) )
import VarEnv ( isEmptyVarEnv )
import Maybes ( orElse )
-import CmdLineOpts
+import DynFlags
import WwLib
import Util ( lengthIs, notNull )
import Outputable
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}
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,
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 )
#include "HsVersions.h"
import HsSyn
-import CmdLineOpts ( DynFlag(..) )
+import DynFlags ( DynFlag(..) )
import Generics ( mkTyConGenericBinds )
import TcRnMonad
enumFromToPName, enumFromThenToPName
)
import ListSetOps ( minusList )
-import CmdLineOpts
+import DynFlags
+import StaticFlags ( opt_NoMethodSharing )
import HscTypes ( TyThing(..) )
import SrcLoc ( Located(..), unLoc, getLoc )
import Util
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 )
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}
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 )
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 )
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 )
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,
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 } } ;
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 )
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 )
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}
import Util ( zipEqual, isSingleton )
import List ( partition )
import SrcLoc ( Located(..) )
-import CmdLineOpts
+import DynFlags ( DynFlag(..) )
+import StaticFlags
\end{code}
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}
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 )
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}
)
-- others
-import CmdLineOpts ( opt_DictsStrict )
+import StaticFlags ( opt_DictsStrict )
import SrcLoc ( noSrcLoc )
import Unique ( Uniquable(..) )
import Util ( mapAccumL, seqList, lengthIs, snocView, thenCmp, isEqual )
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
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,
-- pairs
unzipWith,
- global,
+ global, consIORef,
-- module names
looksLikeModuleName,
-- 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"
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 )
import List ( zipWith4 )
#endif
+import Monad ( when )
+import IO ( catch )
+import Directory ( doesDirectoryExist, createDirectory )
import Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
import Ratio ( (%) )
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}
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}
%************************************************************************
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}
[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}
projects / ghc-hetmet.git / commitdiff