X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fmain%2FDriverState.hs;h=75f2cea701c29373a8f6fc1abfa0f77faa091243;hb=276ee4fab2cb8e28be2b8924e3c85fa1fb902aff;hp=8591f8a699d4e704f1c896a48d6e92134df3031b;hpb=02edb7607692a5168b6636a100a27d2e4063b915;p=ghc-hetmet.git diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index 8591f8a..75f2cea 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.38 2001/05/09 09:38:18 simonmar Exp $ +-- $Id: DriverState.hs,v 1.50 2001/07/20 10:08:56 simonpj Exp $ -- -- Settings for the driver -- @@ -9,24 +9,23 @@ module DriverState where +#include "../includes/config.h" #include "HsVersions.h" -import CmStaticInfo +import Packages ( PackageConfig(..) ) import CmdLineOpts +import DriverPhases import DriverUtil import Util import Config import Exception import IOExts -#ifdef mingw32_TARGET_OS -import TmpFiles ( newTempName ) -import Directory ( removeFile ) -#endif import Panic import List import Char import Monad +import Directory ( doesDirectoryExist ) ----------------------------------------------------------------------------- -- non-configured things @@ -34,10 +33,21 @@ import Monad cHaskell1Version = "5" -- i.e., Haskell 98 ----------------------------------------------------------------------------- --- Global compilation flags +-- GHC modes of operation + +data GhcMode + = DoMkDependHS -- ghc -M + | DoMkDLL -- ghc --mk-dll + | StopBefore Phase -- ghc -E | -C | -S | -c + | DoMake -- ghc --make + | DoInteractive -- ghc --interactive + | DoLink -- [ the default ] + deriving (Eq) --- location of compiler-related files -GLOBAL_VAR(v_TopDir, error "no TOPDIR", String) +GLOBAL_VAR(v_GhcMode, error "mode not set", GhcMode) + +----------------------------------------------------------------------------- +-- Global compilation flags -- Cpp-related flags v_Hs_source_cpp_opts = global @@ -57,7 +67,6 @@ GLOBAL_VAR(v_Keep_tmp_files, False, Bool) -- Misc GLOBAL_VAR(v_Scale_sizes_by, 1.0, Double) -GLOBAL_VAR(v_Dry_run, False, Bool) GLOBAL_VAR(v_Static, True, Bool) GLOBAL_VAR(v_NoHsMain, False, Bool) GLOBAL_VAR(v_Recomp, True, Bool) @@ -69,8 +78,9 @@ GLOBAL_VAR(v_Excess_precision, False, Bool) -- Splitting object files (for libraries) GLOBAL_VAR(v_Split_object_files, False, Bool) -GLOBAL_VAR(v_Split_prefix, "", String) -GLOBAL_VAR(v_N_split_files, 0, Int) +GLOBAL_VAR(v_Split_info, ("",0), (String,Int)) + -- The split prefix and number of files + can_split :: Bool can_split = prefixMatch "i386" cTARGETPLATFORM @@ -97,6 +107,7 @@ GLOBAL_VAR(v_Output_hi, Nothing, Maybe String) GLOBAL_VAR(v_Object_suf, Nothing, Maybe String) GLOBAL_VAR(v_HC_suf, Nothing, Maybe String) +GLOBAL_VAR(v_Hi_dir, Nothing, Maybe String) GLOBAL_VAR(v_Hi_suf, "hi", String) GLOBAL_VAR(v_Ld_inputs, [], [String]) @@ -232,13 +243,21 @@ buildCoreToDo = do ]), CoreDoSimplify (isAmongSimpl [ - MaxSimplifierIterations 2 + MaxSimplifierIterations 3 -- No -finline-phase: allow all Ids to be inlined now -- This gets foldr inlined before strictness analysis + -- + -- 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! ]), - if strictness then CoreDoStrictness else CoreDoNothing, if cpr then CoreDoCPResult else CoreDoNothing, + if strictness then CoreDoStrictness else CoreDoNothing, CoreDoWorkerWrapper, CoreDoGlomBinds, @@ -316,16 +335,72 @@ GLOBAL_VAR(v_Cmdline_libraries, [], [String]) addToDirList :: IORef [String] -> String -> IO () addToDirList ref path - = do paths <- readIORef ref - writeIORef ref (paths ++ split split_marker path) + = do paths <- readIORef ref + shiny_new_ones <- splitUp path + writeIORef ref (paths ++ shiny_new_ones) + + where + splitUp ::String -> IO [String] +#ifdef mingw32_TARGET_OS + -- 'hybrid' support for DOS-style paths in directory lists. + -- + -- That is, if "foo:bar:baz" is used, this interpreted as + -- consisting of three entries, 'foo', 'bar', 'baz'. + -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted + -- as four elts, "c:/foo", "c:\\foo", "x", and "/bar" -- + -- *provided* c:/foo exists and x:/bar doesn't. + -- + -- Notice that no attempt is made to fully replace the 'standard' + -- split marker ':' with the Windows / DOS one, ';'. The reason being + -- that this will cause too much breakage for users & ':' will + -- work fine even with DOS paths, if you're not insisting on being silly. + -- So, use either. + splitUp [] = return [] + splitUp (x:':':div:xs) + | div `elem` dir_markers = do + let (p,rs) = findNextPath xs + ps <- splitUp rs + {- + Consult the file system to check the interpretation + of (x:':':div:p) -- this is arguably excessive, we + could skip this test & just say that it is a valid + dir path. + -} + flg <- doesDirectoryExist (x:':':div:p) + if flg then + return ((x:':':div:p):ps) + else + return ([x]:(div:p):ps) + splitUp xs = do + let (p,rs) = findNextPath xs + ps <- splitUp rs + return (cons p ps) + + cons "" xs = xs + cons x xs = x:xs + + -- will be called either when we've consumed nought or the ":/" part of + -- a DOS path, so splitting is just a Q of finding the next split marker. + findNextPath xs = + case break (`elem` split_markers) xs of + (p, d:ds) -> (p, ds) + (p, xs) -> (p, xs) + + split_markers :: [Char] + split_markers = [':', ';'] + + dir_markers :: [Char] + dir_markers = ['/', '\\'] + +#else + splitUp xs = return (split split_marker xs) +#endif GLOBAL_VAR(v_HCHeader, "", String) ----------------------------------------------------------------------------- -- Packages -GLOBAL_VAR(v_Path_package_config, error "path_package_config", String) - -- package list is maintained in dependency order GLOBAL_VAR(v_Packages, ("std":"rts":"gmp":[]), [String]) @@ -344,7 +419,7 @@ addPackage package getPackageImportPath :: IO [String] getPackageImportPath = do ps <- getPackageInfo - return (nub (concat (map import_dirs ps))) + return (nub (filter (not.null) (concatMap import_dirs ps))) getPackageIncludePath :: IO [String] getPackageIncludePath = do @@ -360,7 +435,7 @@ getPackageCIncludes = do getPackageLibraryPath :: IO [String] getPackageLibraryPath = do ps <- getPackageInfo - return (nub (concat (map library_dirs ps))) + return (nub (filter (not.null) (concatMap library_dirs ps))) getPackageLibraries :: IO [String] getPackageLibraries = do @@ -368,8 +443,29 @@ getPackageLibraries = do tag <- readIORef v_Build_tag let suffix = if null tag then "" else '_':tag return (concat ( - map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps + map (\p -> map (++suffix) (hACK (hs_libraries p)) ++ extra_libraries p) ps )) + where + -- This is a totally horrible (temporary) hack, for Win32. Problem is + -- that package.conf for Win32 says that the main prelude lib is + -- split into HSstd1 and HSstd2, which is needed due to limitations in + -- the PEi386 file format, to make GHCi work. However, we still only + -- have HSstd.a for static linking, not HSstd1.a and HSstd2.a. + -- getPackageLibraries is called to find the .a's to add to the static + -- link line. On Win32, this hACK detects HSstd1 and HSstd2 and + -- replaces them with HSstd, so static linking still works. + -- Libraries needed for dynamic (GHCi) linking are discovered via + -- different route (in InteractiveUI.linkPackage). + -- See driver/PackageSrc.hs for the HSstd1/HSstd2 split definition. + -- THIS IS A STRICTLY TEMPORARY HACK (famous last words ...) + hACK libs +# ifndef mingw32_TARGET_OS + = libs +# else + = if "HSstd1" `elem` libs && "HSstd2" `elem` libs + then "HSstd" : filter ((/= "HSstd").(take 5)) libs + else libs +# endif getPackageExtraGhcOpts :: IO [String] getPackageExtraGhcOpts = do @@ -403,6 +499,7 @@ lookupPkg nm ps = case [p | p <- ps, name p == nm] of [] -> Nothing (p:_) -> Just p + ----------------------------------------------------------------------------- -- Ways @@ -459,7 +556,7 @@ findBuildTag :: IO [String] -- new options findBuildTag = do way_names <- readIORef v_Ways case sort way_names of - [] -> do writeIORef v_Build_tag "" + [] -> do -- writeIORef v_Build_tag "" return [] [w] -> do let details = lkupWay w @@ -587,15 +684,6 @@ unregFlags = ----------------------------------------------------------------------------- -- Programs for particular phases -GLOBAL_VAR(v_Pgm_L, error "pgm_L", String) -GLOBAL_VAR(v_Pgm_P, cRAWCPP, String) -GLOBAL_VAR(v_Pgm_c, cGCC, String) -GLOBAL_VAR(v_Pgm_m, error "pgm_m", String) -GLOBAL_VAR(v_Pgm_s, error "pgm_s", String) -GLOBAL_VAR(v_Pgm_a, cGCC, String) -GLOBAL_VAR(v_Pgm_l, cGCC, String) -GLOBAL_VAR(v_Pgm_dll, cMkDLL, String) - GLOBAL_VAR(v_Opt_dep, [], [String]) GLOBAL_VAR(v_Anti_opt_C, [], [String]) GLOBAL_VAR(v_Opt_C, [], [String])