X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FDriverState.hs;h=c192cad4dcaff6c9e5cda81d5bff2266824bba68;hb=31285afea6a7b553380fd0a01e0a8ce0d7e50878;hp=a31f171294aaa2c9c6b523e3ad7f9877b044d51a;hpb=a3af437651462ff88ae3e55da07a2383361bd37e;p=ghc-hetmet.git diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index a31f171..c192cad 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.42 2001/06/12 17:07:23 simonmar Exp $ +-- $Id: DriverState.hs,v 1.57 2001/09/14 15:51:42 simonpj Exp $ -- -- Settings for the driver -- @@ -12,22 +12,22 @@ module DriverState where #include "../includes/config.h" #include "HsVersions.h" -import CmStaticInfo +import SysTools ( getTopDir ) +import ParsePkgConf ( loadPackageConfig ) +import Packages ( PackageConfig(..), mungePackagePaths ) 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 @@ -35,10 +35,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) + +GLOBAL_VAR(v_GhcMode, error "mode not set", GhcMode) --- location of compiler-related files -GLOBAL_VAR(v_TopDir, error "no TOPDIR", String) +----------------------------------------------------------------------------- +-- Global compilation flags -- Cpp-related flags v_Hs_source_cpp_opts = global @@ -58,20 +69,21 @@ 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) 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) ----------------------------------------------------------------------------- -- 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 @@ -137,6 +149,7 @@ GLOBAL_VAR(v_UsageSPInf, False, Bool) -- Off by default GLOBAL_VAR(v_Strictness, True, Bool) GLOBAL_VAR(v_CPR, True, Bool) GLOBAL_VAR(v_CSE, True, Bool) +GLOBAL_VAR(v_RuleCheck, Nothing, Maybe String) -- these are the static flags you get without -O. hsc_minusNoO_flags = @@ -176,6 +189,7 @@ buildCoreToDo = do strictness <- readIORef v_Strictness cpr <- readIORef v_CPR cse <- readIORef v_CSE + rule_check <- readIORef v_RuleCheck if opt_level == 0 then return [ @@ -234,13 +248,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, @@ -288,7 +310,9 @@ buildCoreToDo = do CoreDoSimplify (isAmongSimpl [ MaxSimplifierIterations max_iter -- No -finline-phase: allow all Ids to be inlined now - ]) + ]), + + case rule_check of { Just pat -> CoreDoRuleCheck pat; Nothing -> CoreDoNothing } ] buildStgToDo :: IO [ StgToDo ] @@ -318,19 +342,88 @@ 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]) +readPackageConf :: String -> IO () +readPackageConf conf_file = do + proto_pkg_details <- loadPackageConfig conf_file + top_dir <- getTopDir + let pkg_details = mungePackagePaths top_dir proto_pkg_details + old_pkg_details <- readIORef v_Package_details + let intersection = filter (`elem` map name old_pkg_details) + (map name pkg_details) + if (not (null intersection)) + then throwDyn (InstallationError ("package `" ++ head intersection ++ "' is already defined")) + else do + writeIORef v_Package_details (pkg_details ++ old_pkg_details) + addPackage :: String -> IO () addPackage package = do pkg_details <- readIORef v_Package_details @@ -346,12 +439,12 @@ addPackage package getPackageImportPath :: IO [String] getPackageImportPath = do ps <- getPackageInfo - munge_paths (concatMap import_dirs ps) + return (nub (filter (not.null) (concatMap import_dirs ps))) getPackageIncludePath :: IO [String] getPackageIncludePath = do ps <- getPackageInfo - munge_paths (concatMap include_dirs ps) + return (nub (filter (not.null) (concatMap include_dirs ps))) -- includes are in reverse dependency order (i.e. rts first) getPackageCIncludes :: IO [String] @@ -362,7 +455,7 @@ getPackageCIncludes = do getPackageLibraryPath :: IO [String] getPackageLibraryPath = do ps <- getPackageInfo - munge_paths (concatMap library_dirs ps) + return (nub (filter (not.null) (concatMap library_dirs ps))) getPackageLibraries :: IO [String] getPackageLibraries = do @@ -370,8 +463,34 @@ 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 ...) + -- JRS 04 Sept 01: Same appalling hack for HSwin32[1,2] + hACK libs +# ifndef mingw32_TARGET_OS + = libs +# else + = if "HSstd1" `elem` libs && "HSstd2" `elem` libs + then "HSstd" : filter ((/= "HSstd").(take 5)) libs + else + if "HSwin321" `elem` libs && "HSwin322" `elem` libs + then "HSwin32" : filter ((/= "HSwin32").(take 7)) libs + else + libs +# endif getPackageExtraGhcOpts :: IO [String] getPackageExtraGhcOpts = do @@ -398,7 +517,7 @@ getPackageDetails ps = do pkg_details <- readIORef v_Package_details return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ] -GLOBAL_VAR(v_Package_details, (error "package_details"), [PackageConfig]) +GLOBAL_VAR(v_Package_details, [], [PackageConfig]) lookupPkg :: String -> [PackageConfig] -> Maybe PackageConfig lookupPkg nm ps @@ -406,13 +525,6 @@ lookupPkg nm ps [] -> Nothing (p:_) -> Just p -munge_paths ps = do - topdir <- readIORef v_TopDir - return (nub (filter (not.null) (map (munge_path topdir) ps))) - where munge_path topdir p - | Just p' <- my_prefix_match "$libdir" p = topdir ++ p' - | otherwise = p - ----------------------------------------------------------------------------- -- Ways @@ -595,20 +707,7 @@ unregFlags = , "-fvia-C" ] ----------------------------------------------------------------------------- --- 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) - -#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS) -GLOBAL_VAR(v_Pgm_T, cTOUCH, String) -#endif +-- Options for particular phases GLOBAL_VAR(v_Opt_dep, [], [String]) GLOBAL_VAR(v_Anti_opt_C, [], [String])