X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FDriverFlags.hs;h=f0f60f769427736731d9b29843edc579148fa0ab;hb=ff9ab413f6ea513f1aea29c987805d022b72109a;hp=89270803474ed644f26753c0d1121377f827809d;hpb=6f57245bd52f902080e003bffe0d511f89b15592;p=ghc-hetmet.git diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 8927080..f0f60f7 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,24 +1,26 @@ -{-# OPTIONS -#include "hschooks.h" #-} - ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.84 2002/01/04 16:02:04 simonmar Exp $ -- -- Driver flags -- --- (c) Simon Marlow 2000 +-- (c) The University of Glasgow 2000-2003 -- ----------------------------------------------------------------------------- module DriverFlags ( - processArgs, OptKind(..), static_flags, dynamic_flags, + processDynamicFlags, + processStaticFlags, + addCmdlineHCInclude, buildStaticHscOpts, - machdepCCOpts + machdepCCOpts, + picCCOpts, + + processArgs, OptKind(..), -- for DriverMkDepend only ) where #include "HsVersions.h" -#include "../includes/config.h" +import MkIface ( showIface ) import DriverState import DriverPhases import DriverUtil @@ -27,11 +29,12 @@ import CmdLineOpts import Config import Util import Panic +import FastString ( mkFastString ) -import Exception -import IOExts -import System ( exitWith, ExitCode(..) ) +import EXCEPTION +import DATA_IOREF ( IORef, readIORef, writeIORef ) +import System ( exitWith, ExitCode(..) ) import IO import Maybe import Monad @@ -59,6 +62,9 @@ import Char ----------------------------------------------------------------------------- -- 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) @@ -95,7 +101,7 @@ processOneArg action rest (dash_arg@('-':arg):args) = if rest /= "" then fio rest >> return args else case args of - [] -> unknownFlagErr dash_arg + [] -> missingArgErr dash_arg (arg1:args1) -> fio arg1 >> return args1 SepArg fio -> @@ -128,7 +134,7 @@ findArg :: [(String,OptKind)] -> String -> Maybe (String,OptKind) findArg spec arg = case [ (remove_spaces rest, k) | (pat,k) <- spec, - Just rest <- [my_prefix_match pat arg], + Just rest <- [maybePrefixMatch pat arg], arg_ok k rest arg ] of [] -> Nothing @@ -137,8 +143,8 @@ findArg spec arg 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 = not (null rest) -arg_ok (PrefixPred p _) rest arg = not (null rest) && p 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 @@ -157,39 +163,38 @@ static_flags = , ( "-help" , NoArg showGhcUsage) , ( "-print-libdir" , NoArg (do getTopDir >>= putStrLn exitWith ExitSuccess)) - , ( "-version" , NoArg (do putStrLn (cProjectName - ++ ", version " ++ cProjectVersion) - 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 Hsc))) + , ( "E" , PassFlag (setMode (StopBefore anyHsc))) , ( "C" , PassFlag (\f -> do setMode (StopBefore HCc) f - setLang HscC)) + setTarget HscC)) , ( "S" , PassFlag (setMode (StopBefore As))) - , ( "c" , PassFlag (setMode (StopBefore Ln))) , ( "-make" , PassFlag (setMode DoMake)) , ( "-interactive" , PassFlag (setMode DoInteractive)) - , ( "-mk-dll" , PassFlag (setMode DoMkDLL)) + , ( "-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 - setLang HscNothing - writeIORef v_Recomp False)) + setTarget HscNothing + setRecompFlag False)) ------- GHCi ------------------------------------------------------- , ( "ignore-dot-ghci", NoArg (writeIORef v_Read_DotGHCi False) ) , ( "read-dot-ghci" , NoArg (writeIORef v_Read_DotGHCi True) ) - ------- recompilation checker -------------------------------------- - , ( "recomp" , NoArg (writeIORef v_Recomp True) ) - , ( "no-recomp" , NoArg (writeIORef v_Recomp False) ) - ------- ways -------------------------------------------------------- , ( "prof" , NoArg (addNoDups v_Ways WayProf) ) , ( "unreg" , NoArg (addNoDups v_Ways WayUnreg) ) @@ -198,8 +203,12 @@ static_flags = , ( "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) ) @@ -221,13 +230,14 @@ static_flags = ------- 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 . Just) ) - , ( "hcsuf" , HasArg (writeIORef v_HC_suf . Just) ) - , ( "hisuf" , HasArg (writeIORef v_Hi_suf) ) + , ( "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) @@ -247,33 +257,44 @@ static_flags = 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" + "warning: don't know how to split object files on this architecture" ) ) ------- Include/Import Paths ---------------------------------------- - , ( "i" , OptPrefix (addToDirList v_Import_paths) ) , ( "I" , Prefix (addToDirList v_Include_paths) ) ------- Libraries --------------------------------------------------- , ( "L" , Prefix (addToDirList v_Library_paths) ) - , ( "l" , Prefix (add v_Cmdline_libraries) ) - - ------- Packages ---------------------------------------------------- - , ( "package-name" , HasArg (\s -> add v_Opt_C ("-inpackage="++s)) ) - - , ( "package-conf" , HasArg (readPackageConf) ) - , ( "package" , HasArg (addPackage) ) - , ( "syslib" , HasArg (addPackage) ) -- for compatibility w/ old vsns + , ( "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 -------------------------------------------- - , ( "pgm" , HasArg setPgm ) + , ( "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 @@ -283,34 +304,11 @@ static_flags = , ( "Rghc-timing" , NoArg (enableTimingStats) ) ------ Compiler flags ----------------------------------------------- - , ( "O2-for-C" , NoArg (writeIORef v_minus_o2_for_C True) ) - , ( "O" , NoArg (setOptLevel 1)) - , ( "Onot" , NoArg (setOptLevel 0)) - , ( "O" , PrefixPred (all isDigit) (setOptLevel . read)) - , ( "fno-asm-mangling" , NoArg (writeIORef v_Do_asm_mangling False) ) - , ( "fmax-simplifier-iterations", - Prefix (writeIORef v_MaxSimplifierIterations . read) ) - - , ( "frule-check", - SepArg (\s -> writeIORef v_RuleCheck (Just s)) ) - - , ( "fusagesp" , NoArg (do writeIORef v_UsageSPInf True - add v_Opt_C "-fusagesp-on") ) - , ( "fexcess-precision" , NoArg (do writeIORef v_Excess_precision True add v_Opt_C "-fexcess-precision")) - -- Optimisation flags are treated specially, so the normal - -- -fno-* pattern below doesn't work. We therefore allow - -- certain optimisation passes to be turned off explicitly: - , ( "fno-strictness" , NoArg (writeIORef v_Strictness False) ) -#ifdef DEBUG - , ( "fno-cpr" , NoArg (writeIORef v_CPR False) ) -#endif - , ( "fno-cse" , NoArg (writeIORef v_CSE False) ) - -- All other "-fno-" options cancel out "-f" on the hsc cmdline , ( "fno-", PrefixPred (\s -> isStaticHscFlag ("f"++s)) (\s -> add v_Anti_opt_C ("-f"++s)) ) @@ -338,64 +336,70 @@ dynamic_flags = [ , ( "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 --------------------------------------------------- - -- With a C compiler whose system() doesn't use a UNIX shell (i.e. - -- mingwin gcc), -D and -U args must *not* be quoted, as the quotes - -- will be interpreted as part of the arguments, and not stripped; - -- on all other systems, quoting is necessary, to avoid interpretation - -- of shell metacharacters in the arguments (e.g. green-card's - -- -DBEGIN_GHC_ONLY='}-' trick). -#ifndef mingw32_TARGET_OS - , ( "D", Prefix (\s -> addOpt_P ("-D'"++s++"'") ) ) - , ( "U", Prefix (\s -> addOpt_P ("-U'"++s++"'") ) ) -#else - , ( "D", Prefix (\s -> addOpt_P ("-D"++s) ) ) - , ( "U", Prefix (\s -> addOpt_P ("-U"++s) ) ) -#endif + , ( "D", AnySuffix addOpt_P ) + , ( "U", AnySuffix addOpt_P ) + + ------- Paths & stuff ----------------------------------------------- + , ( "i" , OptPrefix addImportPath ) ------ Debugging ---------------------------------------------------- , ( "dstg-stats", NoArg (writeIORef v_StgStats True) ) - , ( "ddump-absC", NoArg (setDynFlag Opt_D_dump_absC) ) - , ( "ddump-asm", NoArg (setDynFlag Opt_D_dump_asm) ) - , ( "ddump-cpranal", NoArg (setDynFlag Opt_D_dump_cpranal) ) - , ( "ddump-deriv", NoArg (setDynFlag Opt_D_dump_deriv) ) - , ( "ddump-ds", NoArg (setDynFlag Opt_D_dump_ds) ) - , ( "ddump-flatC", NoArg (setDynFlag Opt_D_dump_flatC) ) - , ( "ddump-foreign", NoArg (setDynFlag Opt_D_dump_foreign) ) - , ( "ddump-inlinings", NoArg (setDynFlag Opt_D_dump_inlinings) ) - , ( "ddump-occur-anal", NoArg (setDynFlag Opt_D_dump_occur_anal) ) - , ( "ddump-parsed", NoArg (setDynFlag Opt_D_dump_parsed) ) - , ( "ddump-realC", NoArg (setDynFlag Opt_D_dump_realC) ) - , ( "ddump-rn", NoArg (setDynFlag Opt_D_dump_rn) ) - , ( "ddump-simpl", NoArg (setDynFlag Opt_D_dump_simpl) ) - , ( "ddump-simpl-iterations", NoArg (setDynFlag Opt_D_dump_simpl_iterations) ) - , ( "ddump-spec", NoArg (setDynFlag Opt_D_dump_spec) ) - , ( "ddump-prep", NoArg (setDynFlag Opt_D_dump_prep) ) - , ( "ddump-stg", NoArg (setDynFlag Opt_D_dump_stg) ) - , ( "ddump-stranal", NoArg (setDynFlag Opt_D_dump_stranal) ) - , ( "ddump-tc", NoArg (setDynFlag Opt_D_dump_tc) ) - , ( "ddump-types", NoArg (setDynFlag Opt_D_dump_types) ) - , ( "ddump-rules", NoArg (setDynFlag Opt_D_dump_rules) ) - , ( "ddump-usagesp", NoArg (setDynFlag Opt_D_dump_usagesp) ) - , ( "ddump-cse", NoArg (setDynFlag Opt_D_dump_cse) ) - , ( "ddump-worker-wrapper", NoArg (setDynFlag Opt_D_dump_worker_wrapper) ) - , ( "dshow-passes", NoArg (setVerbosity "2") ) - , ( "ddump-rn-trace", NoArg (setDynFlag Opt_D_dump_rn_trace) ) - , ( "ddump-tc-trace", NoArg (setDynFlag Opt_D_dump_tc_trace) ) - , ( "ddump-rn-stats", NoArg (setDynFlag Opt_D_dump_rn_stats) ) - , ( "ddump-stix", NoArg (setDynFlag Opt_D_dump_stix) ) - , ( "ddump-simpl-stats", NoArg (setDynFlag Opt_D_dump_simpl_stats) ) - , ( "ddump-bcos", NoArg (setDynFlag Opt_D_dump_BCOs) ) - , ( "dsource-stats", NoArg (setDynFlag Opt_D_source_stats) ) - , ( "dverbose-core2core", NoArg (setDynFlag Opt_D_verbose_core2core) ) - , ( "dverbose-stg2stg", NoArg (setDynFlag Opt_D_verbose_stg2stg) ) - , ( "ddump-hi-diffs", NoArg (setDynFlag Opt_D_dump_hi_diffs) ) - , ( "ddump-hi", NoArg (setDynFlag Opt_D_dump_hi) ) - , ( "ddump-minimal-imports", NoArg (setDynFlag Opt_D_dump_minimal_imports) ) - , ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting) ) - , ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting) ) - , ( "dusagesp-lint", NoArg (setDynFlag Opt_DoUSPLinting) ) + , ( "ddump-cmm", setDumpFlag Opt_D_dump_cmm) + , ( "ddump-asm", setDumpFlag Opt_D_dump_asm) + , ( "ddump-cpranal", setDumpFlag Opt_D_dump_cpranal) + , ( "ddump-deriv", setDumpFlag Opt_D_dump_deriv) + , ( "ddump-ds", setDumpFlag Opt_D_dump_ds) + , ( "ddump-flatC", setDumpFlag Opt_D_dump_flatC) + , ( "ddump-foreign", setDumpFlag Opt_D_dump_foreign) + , ( "ddump-inlinings", setDumpFlag Opt_D_dump_inlinings) + , ( "ddump-occur-anal", setDumpFlag Opt_D_dump_occur_anal) + , ( "ddump-parsed", setDumpFlag Opt_D_dump_parsed) + , ( "ddump-rn", setDumpFlag Opt_D_dump_rn) + , ( "ddump-simpl", setDumpFlag Opt_D_dump_simpl) + , ( "ddump-simpl-iterations", setDumpFlag Opt_D_dump_simpl_iterations) + , ( "ddump-spec", setDumpFlag Opt_D_dump_spec) + , ( "ddump-prep", setDumpFlag Opt_D_dump_prep) + , ( "ddump-stg", setDumpFlag Opt_D_dump_stg) + , ( "ddump-stranal", setDumpFlag Opt_D_dump_stranal) + , ( "ddump-tc", setDumpFlag Opt_D_dump_tc) + , ( "ddump-types", setDumpFlag Opt_D_dump_types) + , ( "ddump-rules", setDumpFlag Opt_D_dump_rules) + , ( "ddump-cse", setDumpFlag Opt_D_dump_cse) + , ( "ddump-worker-wrapper", setDumpFlag Opt_D_dump_worker_wrapper) + , ( "ddump-rn-trace", NoArg (setDynFlag Opt_D_dump_rn_trace)) + , ( "ddump-if-trace", NoArg (setDynFlag Opt_D_dump_if_trace)) + , ( "ddump-tc-trace", setDumpFlag Opt_D_dump_tc_trace) + , ( "ddump-splices", setDumpFlag Opt_D_dump_splices) + , ( "ddump-rn-stats", NoArg (setDynFlag Opt_D_dump_rn_stats)) + , ( "ddump-opt-cmm", setDumpFlag Opt_D_dump_opt_cmm) + , ( "ddump-simpl-stats", setDumpFlag Opt_D_dump_simpl_stats) + , ( "ddump-bcos", setDumpFlag Opt_D_dump_BCOs) + , ( "dsource-stats", setDumpFlag Opt_D_source_stats) + , ( "dverbose-core2core", setDumpFlag Opt_D_verbose_core2core) + , ( "dverbose-stg2stg", setDumpFlag Opt_D_verbose_stg2stg) + , ( "ddump-hi-diffs", setDumpFlag Opt_D_dump_hi_diffs) + , ( "ddump-hi", setDumpFlag Opt_D_dump_hi) + , ( "ddump-minimal-imports", setDumpFlag Opt_D_dump_minimal_imports) + , ( "ddump-vect", setDumpFlag Opt_D_dump_vect) + , ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting)) + , ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting)) + , ( "dcmm-lint", NoArg (setDynFlag Opt_DoCmmLinting)) + , ( "dshow-passes", NoArg (setRecompFlag False >> setVerbosity "2") ) ------ Machine dependant (-m) stuff --------------------------- @@ -405,19 +409,33 @@ dynamic_flags = [ ------ 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 (\_ -> setLang HscAsm) ) - , ( "fvia-c", NoArg (setLang HscC) ) - , ( "fvia-C", NoArg (setLang HscC) ) - , ( "filx", NoArg (setLang HscILX) ) + , ( "fasm", AnySuffix (\_ -> setTarget HscAsm) ) + , ( "fvia-c", NoArg (setTarget HscC) ) + , ( "fvia-C", NoArg (setTarget HscC) ) + , ( "filx", NoArg (setTarget HscILX) ) - -- "active negatives" - , ( "fno-implicit-prelude", NoArg (setDynFlag Opt_NoImplicitPrelude) ) + , ( "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)) ) @@ -430,6 +448,7 @@ 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 ), @@ -441,16 +460,117 @@ fFlags = [ ( "warn-unused-imports", Opt_WarnUnusedImports ), ( "warn-unused-matches", Opt_WarnUnusedMatches ), ( "warn-deprecations", Opt_WarnDeprecations ), - ( "glasgow-exts", Opt_GlasgowExts ), + ( "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 ) + ( "generics", Opt_Generics ), + ( "strictness", Opt_Strictness ), + ( "full-laziness", Opt_FullLaziness ), + ( "cse", Opt_CSE ), + ( "ignore-interface-pragmas", Opt_IgnoreInterfacePragmas ), + ( "omit-interface-pragmas", Opt_OmitInterfacePragmas ), + ( "do-lambda-eta-expansion", Opt_DoLambdaEtaExpansion ), + ( "ignore-asserts", Opt_IgnoreAsserts ), + ( "do-eta-reduction", Opt_DoEtaReduction ), + ( "case-merge", Opt_CaseMerge ), + ( "unbox-strict-fields", Opt_UnboxStrictFields ) ] +glasgowExtsFlags = [ Opt_GlasgowExts, Opt_FFI, Opt_TH, Opt_ImplicitParams, Opt_ScopedTypeVariables ] + isFFlag f = f `elem` (map fst fFlags) getFFlag f = fromJust (lookup f fFlags) +-- ----------------------------------------------------------------------------- +-- Parsing the dynamic flags. + +-- we use a temporary global variable, for convenience + +GLOBAL_VAR(v_DynFlags, defaultDynFlags, DynFlags) + +processDynamicFlags :: [String] -> DynFlags -> IO (DynFlags,[String]) +processDynamicFlags args dflags = do + writeIORef v_DynFlags dflags + spare <- processArgs dynamic_flags args [] + dflags <- readIORef v_DynFlags + return (dflags,spare) + +updDynFlags :: (DynFlags -> DynFlags) -> IO () +updDynFlags f = do dfs <- readIORef v_DynFlags + writeIORef v_DynFlags (f dfs) + +setDynFlag, unSetDynFlag :: DynFlag -> IO () +setDynFlag f = updDynFlags (\dfs -> dopt_set dfs f) +unSetDynFlag f = updDynFlags (\dfs -> dopt_unset dfs f) + +setDumpFlag :: DynFlag -> OptKind +setDumpFlag dump_flag + = NoArg (setRecompFlag False >> setDynFlag dump_flag) + -- Whenver we -ddump, switch off the recompilation checker, + -- else you don't see the dump! + +addOpt_L a = updDynFlags (\s -> s{opt_L = a : opt_L s}) +addOpt_P a = updDynFlags (\s -> s{opt_P = a : opt_P s}) +addOpt_F a = updDynFlags (\s -> s{opt_F = a : opt_F s}) +addOpt_c a = updDynFlags (\s -> s{opt_c = a : opt_c s}) +addOpt_a a = updDynFlags (\s -> s{opt_a = a : opt_a s}) +addOpt_m a = updDynFlags (\s -> s{opt_m = a : opt_m s}) +#ifdef ILX +addOpt_I a = updDynFlags (\s -> s{opt_I = a : opt_I s}) +addOpt_i a = updDynFlags (\s -> s{opt_i = a : opt_i s}) +#endif + +setRecompFlag :: Bool -> IO () +setRecompFlag recomp = updDynFlags (\dfs -> dfs{ recompFlag = recomp }) + +setVerbosity "" = updDynFlags (\dfs -> dfs{ verbosity = 3 }) +setVerbosity n + | all isDigit n = updDynFlags (\dfs -> dfs{ verbosity = read n }) + | otherwise = throwDyn (UsageError "can't parse verbosity flag (-v)") + +addCmdlineHCInclude a = updDynFlags (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s}) + +extraPkgConf_ p = updDynFlags (\s -> s{ extraPkgConfs = p : extraPkgConfs s }) +noUserPkgConf_ = updDynFlags (\s -> s{ readUserPkgConf = False }) + +exposePackage p = + updDynFlags (\s -> s{ packageFlags = ExposePackage p : packageFlags s }) +hidePackage p = + updDynFlags (\s -> s{ packageFlags = HidePackage p : packageFlags s }) +ignorePackage p = + updDynFlags (\s -> s{ packageFlags = IgnorePackage p : packageFlags s }) + +-- -i on its own deletes the import paths +addImportPath "" = updDynFlags (\s -> s{importPaths = []}) +addImportPath p = do + paths <- splitPathList p + updDynFlags (\s -> s{importPaths = importPaths s ++ paths}) + +-- we can only switch between HscC, HscAsmm, and HscILX with dynamic flags +-- (-fvia-C, -fasm, -filx respectively). +setTarget l = updDynFlags (\dfs -> case hscTarget dfs of + HscC -> dfs{ hscTarget = l } + HscAsm -> dfs{ hscTarget = l } + HscILX -> dfs{ hscTarget = l } + _ -> dfs) + +setOptLevel :: Int -> IO () +setOptLevel n + = do dflags <- readIORef v_DynFlags + if hscTarget dflags == HscInterpreted && n > 0 + then putStr "warning: -O conflicts with --interactive; -O ignored.\n" + else writeIORef v_DynFlags (updOptLevel n dflags) + ----------------------------------------------------------------------------- -- convert sizes like "3.5M" into integers @@ -469,8 +589,13 @@ decodeSize str ----------------------------------------------------------------------------- -- 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 @@ -480,21 +605,10 @@ buildStaticHscOpts = do opt_C_ <- getStaticOpts v_Opt_C -- misc hsc opts from the command line - -- optimisation - minus_o <- readIORef v_OptLevel - let optimisation_opts = - case minus_o of - 0 -> hsc_minusNoO_flags - 1 -> hsc_minusO_flags - 2 -> hsc_minusO2_flags - n -> throwDyn (CmdLineError ("unknown optimisation level: " - ++ show n)) - -- ToDo: -Ofile - -- 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_ ++ optimisation_opts + let basic_opts = opt_C_ filtered_opts = filter (`notElem` anti_flags) basic_opts static <- (do s <- readIORef v_Static; if s then return "-static" @@ -502,6 +616,21 @@ buildStaticHscOpts = do 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 @@ -509,19 +638,23 @@ buildStaticHscOpts = do -- , registerised HC compilations -- ) -machdepCCOpts - | prefixMatch "alpha" cTARGETPLATFORM - = return ( ["-static", "-w", "-mieee"], [] ) +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. - | prefixMatch "hppa" cTARGETPLATFORM +#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 ( ["-static", "-D_HPUX_SOURCE"], [] ) + = return ( ["-D_HPUX_SOURCE"], [] ) - | prefixMatch "m68k" cTARGETPLATFORM +#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! @@ -533,54 +666,102 @@ machdepCCOpts -- as on iX86, where we *do* steal the frame pointer [%ebp].) = return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] ) - | prefixMatch "i386" cTARGETPLATFORM +#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 n_regs <- dynFlag stolen_x86_regs + = 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", "-fomit-frame-pointer", + 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 ] ) - | prefixMatch "mips" cTARGETPLATFORM +#elif ia64_TARGET_ARCH + = return ( [], ["-fomit-frame-pointer", "-G0"] ) + +#elif x86_64_TARGET_ARCH + = return ( [], ["-fomit-frame-pointer"] ) + +#elif mips_TARGET_ARCH = return ( ["-static"], [] ) - | prefixMatch "sparc" cTARGETPLATFORM +#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. - | prefixMatch "powerpc-apple-darwin" cTARGETPLATFORM - = return ( ["-no-cpp-precomp"], [""] ) - - | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM - = return ( ["-static"], ["-finhibit-size-directive"] ) - - | otherwise +#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 ------------------------------------------------------------------------------ --- local utils - -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}) +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 -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)") +----------------------------------------------------------------------------- +-- local utils -addCmdlineHCInclude a = updDynFlags (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s}) +-- ----------------------------------------------------------------------------- +-- 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