X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fdriver%2FMain.hs;h=2e235bf8ee15ed58b4cdebfdcada8df527b31475;hb=55416377cceff0d81f6bcd06391f605cba1868cc;hp=02783f9b4cefd1c683ad13e3c2759160cf76db0c;hpb=8041a4b3e8340f09770035f03dc84de9ee1403df;p=ghc-hetmet.git diff --git a/ghc/driver/Main.hs b/ghc/driver/Main.hs index 02783f9..2e235bf 100644 --- a/ghc/driver/Main.hs +++ b/ghc/driver/Main.hs @@ -1,29 +1,43 @@ +{-# OPTIONS -W -fno-warn-incomplete-patterns #-} ----------------------------------------------------------------------------- +-- $Id: Main.hs,v 1.68 2000/10/11 16:06:38 simonmar Exp $ +-- -- GHC Driver program -- -- (c) Simon Marlow 2000 -- ----------------------------------------------------------------------------- +-- with path so that ghc -M can find config.h +#include "../includes/config.h" + module Main (main) where +import GetImports import Package import Config import RegexString import Concurrent +#ifndef mingw32_TARGET_OS import Posix +#endif +import Directory import IOExts import Exception import Dynamic import IO -import Array +import Monad import List import System import Maybe import Char +#ifdef mingw32_TARGET_OS +foreign import "_getpid" getProcessID :: IO Int +#endif + #define GLOBAL_VAR(name,value,ty) \ name = global (value) :: IORef (ty); \ {-# NOINLINE name #-} @@ -31,13 +45,16 @@ name = global (value) :: IORef (ty); \ ----------------------------------------------------------------------------- -- ToDo: +-- certain options in OPTIONS pragmas are persistent through subsequent compilations. +-- new mkdependHS doesn't support all the options that the old one did (-X et al.) -- time commands when run with -v -- split marker -- mkDLL -- java generation -- user ways --- Win32 support +-- 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 ----------------------------------------------------------------------------- -- Differences vs. old driver: @@ -51,18 +68,17 @@ name = global (value) :: IORef (ty); \ ----------------------------------------------------------------------------- -- non-configured things -_Haskell1Version = "5" -- i.e., Haskell 98 +cHaskell1Version = "5" -- i.e., Haskell 98 ----------------------------------------------------------------------------- -- Usage Message -short_usage = do - hPutStr stderr "\nUsage: For basic information, try the `-help' option.\n" - exitWith ExitSuccess +short_usage = "Usage: For basic information, try the `--help' option." long_usage = do - let usage_dir = findFile "ghc-usage.txt" (cGHC_DRIVER_DIR++"/ghc-usage.txt") - usage <- readFile (usage_dir++"/ghc-usage.txt") + let usage_file = "ghc-usage.txt" + usage_path = findFile usage_file (cGHC_DRIVER_DIR ++ '/':usage_file) + usage <- readFile usage_path dump usage exitWith ExitSuccess where @@ -70,10 +86,104 @@ long_usage = do dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s dump (c:s) = hPutChar stderr c >> dump s -version_str = cProjectVersion ++ - ( if cProjectPatchLevel /= "0" && cProjectPatchLevel /= "" - then '.':cProjectPatchLevel - else "") +version_str = cProjectVersion + +----------------------------------------------------------------------------- +-- Driver state + +-- certain flags can be specified on a per-file basis, in an OPTIONS +-- pragma at the beginning of the source file. This means that when +-- compiling mulitple files, we have to restore the global option +-- settings before compiling a new file. +-- +-- The DriverState record contains the per-file-mutable state. + +data DriverState = DriverState { + + -- are we runing cpp on this file? + cpp_flag :: Bool, + + -- heap/stack sizes + specific_heap_size :: Integer, + specific_stack_size :: Integer, + + -- misc + stolen_x86_regs :: Int, + excess_precision :: Bool, + warning_opt :: WarningState, + cmdline_hc_includes :: [String], + + -- options for a particular phase + anti_opt_C :: [String], + opt_dep :: [String], + opt_L :: [String], + opt_P :: [String], + opt_C :: [String], + opt_Crts :: [String], + opt_c :: [String], + opt_a :: [String], + opt_m :: [String], + opt_l :: [String], + opt_dll :: [String] + } + +initDriverState = DriverState { + cpp_flag = False, + specific_heap_size = 6 * 1000 * 1000, + specific_stack_size = 1000 * 1000, + stolen_x86_regs = 4, + excess_precision = False, + warning_opt = W_default, + cmdline_hc_includes = [], + anti_opt_C = [], + opt_dep = [], + opt_L = [], + opt_P = [], + opt_C = [], + opt_Crts = [], + opt_c = [], + opt_a = [], + opt_m = [], + opt_l = [], + opt_dll = [] + } + +GLOBAL_VAR(driver_state, initDriverState, DriverState) + +readState :: (DriverState -> a) -> IO a +readState f = readIORef driver_state >>= return . f + +updateState :: (DriverState -> DriverState) -> IO () +updateState f = readIORef driver_state >>= writeIORef driver_state . f + +addAntiOpt_C a = updateState (\s -> s{anti_opt_C = a : anti_opt_C s}) +addOpt_dep a = updateState (\s -> s{opt_dep = a : opt_dep s}) +addOpt_L a = updateState (\s -> s{opt_L = a : opt_L s}) +addOpt_P a = updateState (\s -> s{opt_P = a : opt_P s}) +addOpt_C a = updateState (\s -> s{opt_C = a : opt_C s}) +addOpt_Crts a = updateState (\s -> s{opt_Crts = a : opt_Crts s}) +addOpt_c a = updateState (\s -> s{opt_c = a : opt_c s}) +addOpt_a a = updateState (\s -> s{opt_a = a : opt_a s}) +addOpt_m a = updateState (\s -> s{opt_m = a : opt_m s}) +addOpt_l a = updateState (\s -> s{opt_l = a : opt_l s}) +addOpt_dll a = updateState (\s -> s{opt_dll = a : opt_dll s}) + +addCmdlineHCInclude a = + updateState (\s -> s{cmdline_hc_includes = a : cmdline_hc_includes s}) + + -- we add to the options from the front, so we need to reverse the list +getOpts :: (DriverState -> [a]) -> IO [a] +getOpts opts = readState opts >>= return . reverse + +newHeapSize :: Integer -> IO () +newHeapSize new = updateState + (\s -> let current = specific_heap_size s in + s{ specific_heap_size = if new > current then new else current }) + +newStackSize :: Integer -> IO () +newStackSize new = updateState + (\s -> let current = specific_stack_size s in + s{ specific_stack_size = if new > current then new else current }) ----------------------------------------------------------------------------- -- Phases @@ -102,23 +212,16 @@ data Phase | SplitAs | As | Ln - deriving (Eq,Ord,Enum,Ix,Show,Bounded) - -initial_phase = Unlit + deriving (Eq) ----------------------------------------------------------------------------- -- Errors data BarfKind - = UnknownFileType String - | UnknownFlag String - | AmbiguousPhase - | MultipleSrcsOneOutput - | UnknownPackage String - | WayCombinationNotSupported [WayName] - | PhaseFailed String ExitCode + = PhaseFailed String ExitCode | Interrupted - | NoInputFiles + | UsageError String -- prints the short usage msg after the error + | OtherError String -- just prints the error message deriving Eq GLOBAL_VAR(prog_name, "ghc", String) @@ -129,25 +232,15 @@ instance Show BarfKind where showsPrec _ e = showString get_prog_name . showString ": " . showBarf e -showBarf AmbiguousPhase - = showString "only one of the flags -M, -E, -C, -S, -c is allowed" -showBarf (UnknownFileType s) - = showString "unknown file type, and linking not done: " . showString s -showBarf (UnknownFlag s) - = showString "unrecognised flag: " . showString s -showBarf MultipleSrcsOneOutput - = showString "can't apply -o option to multiple source files" -showBarf (UnknownPackage s) - = showString "unknown package name: " . showString s -showBarf (WayCombinationNotSupported ws) - = showString "combination not supported: " - . foldr1 (\a b -> a . showChar '/' . b) - (map (showString . wayName . lkupWay) ws) -showBarf (NoInputFiles) - = showString "no input files" +showBarf (UsageError str) = showString str . showChar '\n' . showString short_usage +showBarf (OtherError str) = showString str +showBarf (PhaseFailed phase code) = + showString phase . showString " failed, code = " . shows code +showBarf (Interrupted) = showString "interrupted" -barfKindTc = mkTyCon "BarfKind" +unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f)) +barfKindTc = mkTyCon "BarfKind" instance Typeable BarfKind where typeOf _ = mkAppTy barfKindTc [] @@ -155,78 +248,56 @@ instance Typeable BarfKind where -- Temporary files GLOBAL_VAR(files_to_clean, [], [String]) +GLOBAL_VAR(keep_tmp_files, False, Bool) cleanTempFiles :: IO () cleanTempFiles = do + forget_it <- readIORef keep_tmp_files + unless forget_it $ do + fs <- readIORef files_to_clean verb <- readIORef verbose let blowAway f = - (do on verb (hPutStrLn stderr ("removing: " ++ f)) + (do when verb (hPutStrLn stderr ("removing: " ++ f)) if '*' `elem` f then system ("rm -f " ++ f) >> return () - else removeLink f) + else removeFile f) `catchAllIO` - (\e -> on verb (hPutStrLn stderr + (\_ -> when verb (hPutStrLn stderr ("warning: can't remove tmp file" ++ f))) mapM_ blowAway fs ----------------------------------------------------------------------------- --- Which phase to stop at - -GLOBAL_VAR(stop_after, Ln, Phase) - -end_phase_flag :: String -> Maybe Phase -end_phase_flag "-M" = Just MkDependHS -end_phase_flag "-E" = Just Cpp -end_phase_flag "-C" = Just Hsc -end_phase_flag "-S" = Just Mangle -end_phase_flag "-c" = Just As -end_phase_flag _ = Nothing - -getStopAfter :: [String] - -> IO ( [String] -- rest of command line - , Phase -- stop after phase - , Bool -- do linking? - ) -getStopAfter flags - = case my_partition end_phase_flag flags of - ([] , rest) -> return (rest, As, True) - ([one], rest) -> return (rest, one, False) - (_ , rest) -> throwDyn AmbiguousPhase - ------------------------------------------------------------------------------ -- Global compilation flags -- Cpp-related flags -GLOBAL_VAR(cpp_flag, False, Bool) hs_source_cpp_opts = global - [ "-D__HASKELL1__="++_Haskell1Version + [ "-D__HASKELL1__="++cHaskell1Version , "-D__GLASGOW_HASKELL__="++cProjectVersionInt , "-D__HASKELL98__" , "-D__CONCURRENT_HASKELL__" ] + -- Verbose +GLOBAL_VAR(verbose, False, Bool) +is_verbose = do v <- readIORef verbose; if v then return "-v" else return "" + -- Keep output from intermediate phases GLOBAL_VAR(keep_hi_diffs, False, Bool) GLOBAL_VAR(keep_hc_files, False, Bool) GLOBAL_VAR(keep_s_files, False, Bool) GLOBAL_VAR(keep_raw_s_files, False, Bool) - -- Compiler RTS options -GLOBAL_VAR(specific_heap_size, 6 * 1000 * 1000, Integer) -GLOBAL_VAR(specific_stack_size, 1000 * 1000, Integer) -GLOBAL_VAR(scale_sizes_by, 1.0, Double) - - -- Verbose -GLOBAL_VAR(verbose, False, Bool) -is_verbose = do v <- readIORef verbose; if v then return "-v" else return "" - -- Misc +GLOBAL_VAR(scale_sizes_by, 1.0, Double) GLOBAL_VAR(dry_run, False, Bool) GLOBAL_VAR(recomp, True, Bool) -GLOBAL_VAR(tmp_prefix, cTMPDIR, String) -GLOBAL_VAR(stolen_x86_regs, 4, Int) -GLOBAL_VAR(static, True, Bool) -- ToDo: not for mingw32 +GLOBAL_VAR(tmpdir, cDEFAULT_TMPDIR, String) +#if !defined(HAVE_WIN32_DLL_SUPPORT) || defined(DONT_WANT_WIN32_DLL_SUPPORT) +GLOBAL_VAR(static, True, Bool) +#else +GLOBAL_VAR(static, False, Bool) +#endif GLOBAL_VAR(collect_ghc_timing, False, Bool) GLOBAL_VAR(do_asm_mangling, True, Bool) @@ -254,9 +325,11 @@ data HscLang = HscC | HscAsm | HscJava + deriving Eq GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" && - prefixMatch "i386" cTARGETPLATFORM + (prefixMatch "i386" cTARGETPLATFORM || + prefixMatch "sparc" cTARGETPLATFORM) then HscAsm else HscC, HscLang) @@ -323,12 +396,11 @@ minusWallOpts = minusWOpts ++ [ "-fwarn-type-defaults" , "-fwarn-name-shadowing" , "-fwarn-missing-signatures" + , "-fwarn-hi-shadowing" ] data WarningState = W_default | W_ | W_all | W_not -GLOBAL_VAR(warning_opt, W_default, WarningState) - ----------------------------------------------------------------------------- -- Compiler optimisation options @@ -340,8 +412,8 @@ setOptLevel "not" = writeIORef opt_level 0 setOptLevel [c] | isDigit c = do let level = ord c - ord '0' writeIORef opt_level level - on (level >= 1) go_via_C -setOptLevel s = throwDyn (UnknownFlag ("-O"++s)) + when (level >= 1) go_via_C +setOptLevel s = unknownFlagErr ("-O"++s) go_via_C = do l <- readIORef hsc_lang @@ -436,7 +508,6 @@ hsc_minusO_flags = do "-fmax-simplifier-iterations2", "]", - "-fsimplify", "[", "-fmax-simplifier-iterations2", @@ -447,6 +518,7 @@ hsc_minusO_flags = do "-fstrictness", "-fcpr-analyse", "-fworker-wrapper", + "-fglom-binds", "-fsimplify", "[", @@ -502,7 +574,7 @@ hsc_minusO_flags = do ----------------------------------------------------------------------------- -- Paths & Libraries -split_marker = ':' -- not configurable +split_marker = ':' -- not configurable (ToDo) import_paths, include_paths, library_paths :: IORef [String] GLOBAL_VAR(import_paths, ["."], [String]) @@ -510,28 +582,93 @@ GLOBAL_VAR(include_paths, ["."], [String]) GLOBAL_VAR(library_paths, [], [String]) GLOBAL_VAR(cmdline_libraries, [], [String]) -GLOBAL_VAR(cmdline_hc_includes, [], [String]) - -augment_import_paths :: String -> IO () -augment_import_paths "" = writeIORef import_paths [] -augment_import_paths path - = do paths <- readIORef import_paths - writeIORef import_paths (paths ++ dirs) - where dirs = split split_marker path -augment_include_paths :: String -> IO () -augment_include_paths path - = do paths <- readIORef include_paths - writeIORef include_paths (paths ++ split split_marker path) - -augment_library_paths :: String -> IO () -augment_library_paths path - = do paths <- readIORef library_paths - writeIORef library_paths (paths ++ split split_marker path) +addToDirList :: IORef [String] -> String -> IO () +addToDirList ref path + = do paths <- readIORef ref + writeIORef ref (paths ++ split split_marker path) ----------------------------------------------------------------------------- -- Packages +GLOBAL_VAR(package_config, (findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")), String) + +listPackages :: IO () +listPackages = do + details <- readIORef package_details + hPutStr stdout (listPkgs details) + hPutChar stdout '\n' + exitWith ExitSuccess + +newPackage :: IO () +newPackage = do + checkConfigAccess + details <- readIORef package_details + hPutStr stdout "Reading package info from stdin... " + stuff <- getContents + let new_pkg = read stuff :: Package + catchAll new_pkg + (\_ -> throwDyn (OtherError "parse error in package info")) + hPutStrLn stdout "done." + if (name new_pkg `elem` map name details) + then throwDyn (OtherError ("package `" ++ name new_pkg ++ + "' already installed")) + else do + conf_file <- readIORef package_config + savePackageConfig conf_file + maybeRestoreOldConfig conf_file $ do + writeNewConfig conf_file ( ++ [new_pkg]) + exitWith ExitSuccess + +deletePackage :: String -> IO () +deletePackage pkg = do + checkConfigAccess + details <- readIORef package_details + if (pkg `notElem` map name details) + then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed")) + else do + conf_file <- readIORef package_config + savePackageConfig conf_file + maybeRestoreOldConfig conf_file $ do + writeNewConfig conf_file (filter ((/= pkg) . name)) + exitWith ExitSuccess + +checkConfigAccess :: IO () +checkConfigAccess = do + conf_file <- readIORef package_config + access <- getPermissions conf_file + unless (writable access) + (throwDyn (OtherError "you don't have permission to modify the package configuration file")) + +maybeRestoreOldConfig :: String -> IO () -> IO () +maybeRestoreOldConfig conf_file io + = catchAllIO io (\e -> do + hPutStr stdout "\nWARNING: an error was encountered while the new \n\ + \configuration was being written. Attempting to \n\ + \restore the old configuration... " + system ("cp " ++ conf_file ++ ".old " ++ conf_file) + hPutStrLn stdout "done." + throw e + ) + +writeNewConfig :: String -> ([Package] -> [Package]) -> IO () +writeNewConfig conf_file fn = do + hPutStr stdout "Writing new package config file... " + old_details <- readIORef package_details + h <- openFile conf_file WriteMode + hPutStr h (dumpPackages (fn old_details)) + hClose h + hPutStrLn stdout "done." + +savePackageConfig :: String -> IO () +savePackageConfig conf_file = do + hPutStr stdout "Saving old package config file... " + -- mv rather than cp because we've already done an hGetContents + -- on this file so we won't be able to open it for writing + -- unless we move the old one out of the way... + system ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old") + hPutStrLn stdout "done." + -- package list is maintained in dependency order packages = global ["std", "rts", "gmp"] :: IORef [String] -- comma in value, so can't use macro, grrr @@ -540,15 +677,14 @@ packages = global ["std", "rts", "gmp"] :: IORef [String] addPackage :: String -> IO () addPackage package = do pkg_details <- readIORef package_details - case lookup package pkg_details of - Nothing -> throwDyn (UnknownPackage package) + case lookupPkg package pkg_details of + Nothing -> throwDyn (OtherError ("unknown package name: " ++ package)) Just details -> do ps <- readIORef packages - if package `elem` ps - then return () - else do mapM_ addPackage (package_deps details) - ps <- readIORef packages - writeIORef packages (package:ps) + unless (package `elem` ps) $ do + mapM_ addPackage (package_deps details) + ps <- readIORef packages + writeIORef packages (package:ps) getPackageImportPath :: IO [String] getPackageImportPath = do @@ -558,16 +694,16 @@ getPackageImportPath = do getPackageIncludePath :: IO [String] getPackageIncludePath = do - ps <- readIORef packages + ps <- readIORef packages ps' <- getPackageDetails ps - return (nub (filter (not.null) (map include_dir ps'))) + return (nub (filter (not.null) (concatMap include_dirs ps'))) -- includes are in reverse dependency order (i.e. rts first) getPackageCIncludes :: IO [String] getPackageCIncludes = do ps <- readIORef packages ps' <- getPackageDetails ps - return (reverse (nub (filter (not.null) (map c_include ps')))) + return (reverse (nub (filter (not.null) (concatMap c_includes ps')))) getPackageLibraryPath :: IO [String] getPackageLibraryPath = do @@ -581,34 +717,40 @@ getPackageLibraries = do ps' <- getPackageDetails ps tag <- readIORef build_tag let suffix = if null tag then "" else '_':tag - return (concat (map libraries ps')) + return (concat ( + map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps' + )) getPackageExtraGhcOpts :: IO [String] getPackageExtraGhcOpts = do ps <- readIORef packages ps' <- getPackageDetails ps - return (map extra_ghc_opts ps') + return (concatMap extra_ghc_opts ps') getPackageExtraCcOpts :: IO [String] getPackageExtraCcOpts = do ps <- readIORef packages ps' <- getPackageDetails ps - return (map extra_cc_opts ps') + return (concatMap extra_cc_opts ps') getPackageExtraLdOpts :: IO [String] getPackageExtraLdOpts = do ps <- readIORef packages ps' <- getPackageDetails ps - return (map extra_ld_opts ps') + return (concatMap extra_ld_opts ps') +getPackageDetails :: [String] -> IO [Package] getPackageDetails ps = do pkg_details <- readIORef package_details - let getDetails p = case lookup p pkg_details of - Just details -> return details - Nothing -> error "getPackageDetails" - mapM getDetails ps + return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ] + +GLOBAL_VAR(package_details, (error "package_details"), [Package]) -GLOBAL_VAR(package_details, (error "package_details"), [(String,Package)]) +lookupPkg :: String -> [Package] -> Maybe Package +lookupPkg nm ps + = case [p | p <- ps, name p == nm] of + [] -> Nothing + (p:_) -> Just p ----------------------------------------------------------------------------- -- Ways @@ -631,6 +773,7 @@ GLOBAL_VAR(build_tag, "", String) data WayName = WayProf | WayUnreg + | WayDll | WayTicky | WayPar | WayGran @@ -657,6 +800,8 @@ data WayName GLOBAL_VAR(ways, [] ,[WayName]) +-- ToDo: allow WayDll with any other allowed combination + allowed_combinations = [ [WayProf,WayUnreg], [WayProf,WaySMP] -- works??? @@ -674,7 +819,10 @@ findBuildTag = do return (wayOpts details) ws -> if ws `notElem` allowed_combinations - then throwDyn (WayCombinationNotSupported ws) + then throwDyn (OtherError $ + "combination not supported: " ++ + foldr1 (\a b -> a ++ '/':b) + (map (wayName . lkupWay) ws)) else let stuff = map lkupWay ws tag = concat (map wayTag stuff) flags = map wayOpts stuff @@ -698,38 +846,45 @@ way_details = [ (WayProf, Way "p" "Profiling" [ "-fscc-profiling" , "-DPROFILING" - , "-optc-DPROFILING" ]), + , "-optc-DPROFILING" + , "-fvia-C" ]), (WayTicky, Way "t" "Ticky-ticky Profiling" [ "-fticky-ticky" , "-DTICKY_TICKY" - , "-optc-DTICKY_TICKY" ]), + , "-optc-DTICKY_TICKY" + , "-fvia-C" ]), (WayUnreg, Way "u" "Unregisterised" [ "-optc-DNO_REGS" , "-optc-DUSE_MINIINTERPRETER" , "-fno-asm-mangling" - , "-funregisterised" ]), + , "-funregisterised" + , "-fvia-C" ]), + + (WayDll, Way "dll" "DLLized" + [ ]), (WayPar, Way "mp" "Parallel" - [ "-fstack-check" - , "-fparallel" + [ "-fparallel" , "-D__PARALLEL_HASKELL__" , "-optc-DPAR" - , "-package concurrent" ]), + , "-package concurrent" + , "-fvia-C" ]), (WayGran, Way "mg" "Gransim" - [ "-fstack-check" - , "-fgransim" + [ "-fgransim" , "-D__GRANSIM__" , "-optc-DGRAN" - , "-package concurrent" ]), + , "-package concurrent" + , "-fvia-C" ]), - (WaySMP, Way "s" "SMP" + (WaySMP, Way "s" "SMP" [ "-fsmp" , "-optc-pthread" , "-optl-pthread" - , "-optc-DSMP" ]), + , "-optc-DSMP" + , "-fvia-C" ]), (WayUser_a, Way "a" "User way 'a'" ["$WAY_a_REAL_OPTS"]), (WayUser_b, Way "b" "User way 'b'" ["$WAY_b_REAL_OPTS"]), @@ -753,7 +908,6 @@ way_details = ----------------------------------------------------------------------------- -- Programs for particular phases -GLOBAL_VAR(pgm_dep, findFile "mkdependHS" cGHC_MKDEPENDHS, String) GLOBAL_VAR(pgm_L, findFile "unlit" cGHC_UNLIT, String) GLOBAL_VAR(pgm_P, cRAWCPP, String) GLOBAL_VAR(pgm_C, findFile "hsc" cGHC_HSC, String) @@ -764,26 +918,6 @@ GLOBAL_VAR(pgm_a, cGCC, String) GLOBAL_VAR(pgm_l, cGCC, String) ----------------------------------------------------------------------------- --- Options for particular phases - -GLOBAL_VAR(opt_dep, [], [String]) -GLOBAL_VAR(opt_L, [], [String]) -GLOBAL_VAR(opt_P, [], [String]) -GLOBAL_VAR(opt_C, [], [String]) -GLOBAL_VAR(opt_Crts, [], [String]) -GLOBAL_VAR(opt_c, [], [String]) -GLOBAL_VAR(opt_a, [], [String]) -GLOBAL_VAR(opt_m, [], [String]) -GLOBAL_VAR(opt_l, [], [String]) -GLOBAL_VAR(opt_dll, [], [String]) - - -- we add to the options from the front, so we need to reverse the list -getOpts :: IORef [String] -> IO [String] -getOpts opts = readIORef opts >>= return . reverse - -GLOBAL_VAR(anti_opt_C, [], [String]) - ------------------------------------------------------------------------------ -- Via-C compilation stuff -- flags returned are: ( all C compilations @@ -816,7 +950,7 @@ machdepCCOpts -- -- -fomit-frame-pointer : *must* in .hc files; because we're stealing -- the fp (%ebp) for our register maps. - = do n_regs <- readIORef stolen_x86_regs + = do n_regs <- readState stolen_x86_regs sta <- readIORef static return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" ], [ "-fno-defer-pop", "-fomit-frame-pointer", @@ -840,7 +974,7 @@ build_hsc_opts = do opt_C_ <- getOpts opt_C -- misc hsc opts -- warnings - warn_level <- readIORef warning_opt + warn_level <- readState warning_opt let warn_opts = case warn_level of W_default -> standardWarnings W_ -> minusWOpts @@ -854,6 +988,7 @@ build_hsc_opts = do 0 -> hsc_minusNoO_flags 1 -> hsc_minusO_flags 2 -> hsc_minusO2_flags + _ -> error "unknown opt level" -- ToDo: -Ofile -- STG passes @@ -899,8 +1034,8 @@ build_hsc_opts = do hi_map_sep = "-himap-sep=" ++ [split_marker] scale <- readIORef scale_sizes_by - heap <- readIORef specific_heap_size - stack <- readIORef specific_stack_size + heap <- readState specific_heap_size + stack <- readState specific_stack_size cmdline_rts_opts <- getOpts opt_Crts let heap' = truncate (fromIntegral heap * scale) :: Integer stack' = truncate (fromIntegral stack * scale) :: Integer @@ -939,18 +1074,20 @@ getOptionsFromSource -> IO [String] -- options, if any getOptionsFromSource file = do h <- openFile file ReadMode - look h + catchJust ioErrors (look h) + (\e -> if isEOFError e then return [] else ioError e) where look h = do l <- hGetLine h case () of () | null l -> look h - | prefixMatch "{-# LINE" l -> look h + | prefixMatch "#" l -> look h + | prefixMatch "{-# LINE" l -> look h -- -} | Just (opts:_) <- matchRegex optionRegex l -> return (words opts) | otherwise -> return [] -optionRegex = mkRegex "{-#[ \t]+OPTIONS[ \t]+(.*)#-}" +optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}" -- -} ----------------------------------------------------------------------------- -- Main loop @@ -958,48 +1095,14 @@ optionRegex = mkRegex "{-#[ \t]+OPTIONS[ \t]+(.*)#-}" get_source_files :: [String] -> ([String],[String]) get_source_files = partition (('-' /=) . head) -suffixes :: [(String,Phase)] -suffixes = - [ ("lhs", Unlit) - , ("hs", Cpp) - , ("hc", HCc) - , ("c", Cc) - , ("raw_s", Mangle) - , ("s", As) - , ("S", As) - , ("o", Ln) - ] - -phase_input_ext Unlit = "lhs" -phase_input_ext Cpp = "lpp" -phase_input_ext Hsc = "cpp" -phase_input_ext HCc = "hc" -phase_input_ext Cc = "c" -phase_input_ext Mangle = "raw_s" -phase_input_ext SplitMangle = "split_s" -- not really generated -phase_input_ext As = "s" -phase_input_ext SplitAs = "split_s" -- not really generated -phase_input_ext Ln = "o" - -find_phase :: String -> ([(Phase,String)], [String]) - -> ([(Phase,String)], [String]) -find_phase f (phase_srcs, unknown_srcs) - = case lookup ext suffixes of - Just the_phase -> ((the_phase,f):phase_srcs, unknown_srcs) - Nothing -> (phase_srcs, f:unknown_srcs) - where (basename,ext) = split_filename f - - -find_phases srcs = (phase_srcs, unknown_srcs) - where (phase_srcs, unknown_srcs) = foldr find_phase ([],[]) srcs - main = -- all error messages are propagated as exceptions my_catchDyn (\dyn -> case dyn of - PhaseFailed phase code -> exitWith code + PhaseFailed _phase code -> exitWith code Interrupted -> exitWith (ExitFailure 1) _ -> do hPutStrLn stderr (show (dyn :: BarfKind)) - exitWith (ExitFailure 1)) $ + exitWith (ExitFailure 1) + ) $ later cleanTempFiles $ -- exceptions will be blocked while we clean the temporary files, @@ -1009,75 +1112,121 @@ main = do -- install signal handlers main_thread <- myThreadId + +#ifndef mingw32_TARGET_OS let sig_handler = Catch (raiseInThread main_thread (DynException (toDyn Interrupted))) installHandler sigQUIT sig_handler Nothing installHandler sigINT sig_handler Nothing +#endif pgm <- getProgName writeIORef prog_name pgm argv <- getArgs - -- grab any -B options from the command line first + -- grab any -B options from the command line first argv' <- setTopDir argv - -- read the package configuration - let conf = findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace") - contents <- readFile conf + -- check whether TMPDIR is set in the environment +#ifndef mingw32_TARGET_OS + IO.try (do dir <- getEnv "TMPDIR" -- fails if not set + writeIORef tmpdir dir) +#endif + + -- read the package configuration + conf_file <- readIORef package_config + contents <- readFile conf_file writeIORef package_details (read contents) - -- find the phase to stop after (i.e. -E, -C, -c, -S flags) - (flags2, stop_phase, do_linking) <- getStopAfter argv' + -- find the phase to stop after (i.e. -E, -C, -c, -S flags) + (flags2, todo, stop_flag) <- getToDo argv' + writeIORef v_todo todo - -- process all the other arguments, and get the source files - srcs <- processArgs flags2 [] + -- process all the other arguments, and get the source files + srcs <- processArgs driver_opts flags2 [] - -- find the build tag, and re-process the build-specific options + -- find the build tag, and re-process the build-specific options more_opts <- findBuildTag - _ <- processArgs more_opts [] + _ <- processArgs driver_opts more_opts [] - if stop_phase == MkDependHS -- mkdependHS is special - then do_mkdependHS flags2 srcs - else do + -- get the -v flag + verb <- readIORef verbose + + when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file)) + + -- mkdependHS is special + when (todo == DoMkDependHS) beginMkDependHS - -- for each source file, find which phase to start at - let (phase_srcs, unknown_srcs) = find_phases srcs + -- for each source file, find which phases to run + pipelines <- mapM (genPipeline todo stop_flag) srcs + let src_pipelines = zip srcs pipelines o_file <- readIORef output_file - if isJust o_file && not do_linking && length phase_srcs > 1 - then throwDyn MultipleSrcsOneOutput + if isJust o_file && todo /= DoLink && length srcs > 1 + then throwDyn (UsageError "can't apply -o option to multiple source files") else do - if null unknown_srcs && null phase_srcs - then throwDyn NoInputFiles - else do + if null srcs then throwDyn (UsageError "no input files") else do - -- if we have unknown files, and we're not doing linking, complain - -- (otherwise pass them through to the linker). - if not (null unknown_srcs) && not do_linking - then throwDyn (UnknownFileType (head unknown_srcs)) - else do + -- save the flag state, because this could be modified by OPTIONS pragmas + -- during the compilation, and we'll need to restore it before starting + -- the next compilation. + saved_driver_state <- readIORef driver_state + + let compileFile (src, phases) = do + r <- run_pipeline phases src (todo==DoLink) True orig_base orig_suff + writeIORef driver_state saved_driver_state + return r + where (orig_base, orig_suff) = splitFilename src + + o_files <- mapM compileFile src_pipelines + + when (todo == DoMkDependHS) endMkDependHS + + when (todo == DoLink) (do_link o_files) - let compileFile :: (Phase, String) -> IO String - compileFile (phase, src) = do - let (orig_base, _) = split_filename src - if phase < Ln -- anything to do? - then run_pipeline stop_phase do_linking True orig_base (phase,src) - else return src - o_files <- mapM compileFile phase_srcs +----------------------------------------------------------------------------- +-- Which phase to stop at + +data ToDo = DoMkDependHS | DoMkDLL | StopBefore Phase | DoLink + deriving (Eq) + +GLOBAL_VAR(v_todo, error "todo", ToDo) + +todoFlag :: String -> Maybe ToDo +todoFlag "-M" = Just $ DoMkDependHS +todoFlag "-E" = Just $ StopBefore Hsc +todoFlag "-C" = Just $ StopBefore HCc +todoFlag "-S" = Just $ StopBefore As +todoFlag "-c" = Just $ StopBefore Ln +todoFlag _ = Nothing - if do_linking - then do_link o_files unknown_srcs - else return () +getToDo :: [String] + -> IO ( [String] -- rest of command line + , ToDo -- phase to stop at + , String -- "stop at" flag + ) +getToDo flags + = case my_partition todoFlag flags of + ([] , rest) -> return (rest, DoLink, "") -- default is to do linking + ([(flag,one)], rest) -> return (rest, one, flag) + (_ , _ ) -> + throwDyn (OtherError "only one of the flags -M, -E, -C, -S, -c is allowed") +----------------------------------------------------------------------------- +-- genPipeline +-- +-- Herein is all the magic about which phases to run in which order, whether +-- the intermediate files should be in /tmp or in the current directory, +-- what the suffix of the intermediate files should be, etc. -- The following compilation pipeline algorithm is fairly hacky. A --- better way to do this would be to express the whole comilation as a +-- better way to do this would be to express the whole compilation as a -- data flow DAG, where the nodes are the intermediate files and the -- edges are the compilation phases. This framework would also work --- nicely if a haskell dependency generator was included in the +-- nicely if a Haskell dependency generator were included in the -- driver. -- It would also deal much more cleanly with compilation phases that @@ -1091,151 +1240,418 @@ main = -- the host machine. For example, when compiling two Haskell files -- where one depends on the other, the data flow graph would determine -- that the C compiler from the first comilation can be overlapped --- with the hsc comilation for the second file. +-- with the hsc compilation for the second file. + +data IntermediateFileType + = Temporary + | Persistent + deriving (Eq) + +-- the first compilation phase for a given file is determined +-- by its suffix. +startPhase "lhs" = Unlit +startPhase "hs" = Cpp +startPhase "hc" = HCc +startPhase "c" = Cc +startPhase "raw_s" = Mangle +startPhase "s" = As +startPhase "S" = As +startPhase "o" = Ln +startPhase _ = Ln -- all unknown file types + +genPipeline + :: ToDo -- when to stop + -> String -- "stop after" flag (for error messages) + -> String -- original filename + -> IO [ -- list of phases to run for this file + (Phase, + IntermediateFileType, -- keep the output from this phase? + String) -- output file suffix + ] + +genPipeline todo stop_flag filename + = do + split <- readIORef split_object_files + mangle <- readIORef do_asm_mangling + lang <- readIORef hsc_lang + keep_hc <- readIORef keep_hc_files + keep_raw_s <- readIORef keep_raw_s_files + keep_s <- readIORef keep_s_files + + let + ----------- ----- ---- --- -- -- - - - + (_basename, suffix) = splitFilename filename + + start_phase = startPhase suffix + + haskell_ish_file = suffix `elem` [ "hs", "lhs", "hc" ] + c_ish_file = suffix `elem` [ "c", "s", "S" ] -- maybe .cc et al.?? + + -- for a .hc file, or if the -C flag is given, we need to force lang to HscC + real_lang + | suffix == "hc" = HscC + | todo == StopBefore HCc && lang /= HscC && haskell_ish_file = HscC + | otherwise = lang + + let + ----------- ----- ---- --- -- -- - - - + pipeline + | todo == DoMkDependHS = [ Unlit, Cpp, MkDependHS ] + + | haskell_ish_file = + case real_lang of + HscC | split && mangle -> [ Unlit, Cpp, Hsc, HCc, Mangle, + SplitMangle, SplitAs ] + | mangle -> [ Unlit, Cpp, Hsc, HCc, Mangle, As ] + | split -> not_valid + | otherwise -> [ Unlit, Cpp, Hsc, HCc, As ] + + HscAsm | split -> [ Unlit, Cpp, Hsc, SplitMangle, SplitAs ] + | otherwise -> [ Unlit, Cpp, Hsc, As ] + + HscJava | split -> not_valid + | otherwise -> error "not implemented: compiling via Java" + + | c_ish_file = [ Cc, As ] + + | otherwise = [ ] -- just pass this file through to the linker + + -- ToDo: this is somewhat cryptic + not_valid = throwDyn (OtherError ("invalid option combination")) + ----------- ----- ---- --- -- -- - - - + + -- this shouldn't happen. + if start_phase /= Ln && start_phase `notElem` pipeline + then throwDyn (OtherError ("can't find starting phase for " + ++ filename)) + else do + + -- if we can't find the phase we're supposed to stop before, + -- something has gone wrong. + case todo of + StopBefore phase -> + when (phase /= Ln + && phase `notElem` pipeline + && not (phase == As && SplitAs `elem` pipeline)) $ + throwDyn (OtherError + ("flag " ++ stop_flag + ++ " is incompatible with source file `" ++ filename ++ "'")) + _ -> return () + + let + ----------- ----- ---- --- -- -- - - - + annotatePipeline + :: [Phase] -- raw pipeline + -> Phase -- phase to stop before + -> [(Phase, IntermediateFileType, String{-file extension-})] + annotatePipeline [] _ = [] + annotatePipeline (Ln:_) _ = [] + annotatePipeline (phase:next_phase:ps) stop = + (phase, keep_this_output, phase_input_ext next_phase) + : annotatePipeline (next_phase:ps) stop + where + keep_this_output + | next_phase == stop = Persistent + | otherwise = + case next_phase of + Ln -> Persistent + Mangle | keep_raw_s -> Persistent + As | keep_s -> Persistent + HCc | keep_hc -> Persistent + _other -> Temporary + + -- add information about output files to the pipeline + -- the suffix on an output file is determined by the next phase + -- in the pipeline, so we add linking to the end of the pipeline + -- to force the output from the final phase to be a .o file. + stop_phase = case todo of StopBefore phase -> phase + DoMkDependHS -> Ln + DoLink -> Ln + annotated_pipeline = annotatePipeline (pipeline ++ [ Ln ]) stop_phase + + phase_ne p (p1,_,_) = (p1 /= p) + ----------- ----- ---- --- -- -- - - - + + return $ + dropWhile (phase_ne start_phase) . + foldr (\p ps -> if phase_ne stop_phase p then p:ps else []) [] + $ annotated_pipeline + + + +-- the output suffix for a given phase is uniquely determined by +-- the input requirements of the next phase. +phase_input_ext Unlit = "lhs" +phase_input_ext Cpp = "lpp" +phase_input_ext Hsc = "cpp" +phase_input_ext HCc = "hc" +phase_input_ext Cc = "c" +phase_input_ext Mangle = "raw_s" +phase_input_ext SplitMangle = "split_s" -- not really generated +phase_input_ext As = "s" +phase_input_ext SplitAs = "split_s" -- not really generated +phase_input_ext Ln = "o" +phase_input_ext MkDependHS = "dep" run_pipeline - :: Phase -- phase to end on (never Linker) - -> Bool -- doing linking afterward? - -> Bool -- take into account -o when generating output? - -> String -- original basename (eg. Main) - -> (Phase, String) -- phase to run, input file - -> IO String -- return final filename - -run_pipeline last_phase do_linking use_ofile orig_basename (phase, input_fn) - | phase > last_phase = return input_fn - | otherwise + :: [ (Phase, IntermediateFileType, String) ] -- phases to run + -> String -- input file + -> Bool -- doing linking afterward? + -> Bool -- take into account -o when generating output? + -> String -- original basename (eg. Main) + -> String -- original suffix (eg. hs) + -> IO String -- return final filename + +run_pipeline [] input_fn _ _ _ _ = return input_fn +run_pipeline ((phase, keep, o_suffix):phases) + input_fn do_linking use_ofile orig_basename orig_suffix = do - let (basename,ext) = split_filename input_fn - - split <- readIORef split_object_files - mangle <- readIORef do_asm_mangling - lang <- readIORef hsc_lang - - -- figure out what the next phase is. This is - -- straightforward, apart from the fact that hsc can generate - -- either C or assembler direct, and assembly mangling is - -- optional, and splitting involves one extra phase and an alternate - -- assembler. - let next_phase = - case phase of - Hsc -> case lang of - HscC -> HCc - HscAsm -> As - - HCc | mangle -> Mangle - | otherwise -> As - - Cc -> As - - Mangle | not split -> As - SplitMangle -> SplitAs - SplitAs -> Ln - - _ -> succ phase - - - -- filename extension for the output, determined by next_phase - let new_ext = phase_input_ext next_phase - - -- Figure out what the output from this pass should be called. - - -- If we're keeping the output from this phase, then we just save - -- it in the current directory, otherwise we generate a new temp file. - keep_s <- readIORef keep_s_files - keep_raw_s <- readIORef keep_raw_s_files - keep_hc <- readIORef keep_hc_files - let keep_this_output = - case next_phase of - Ln -> True - Mangle | keep_raw_s -> True -- first enhancement :) - As | keep_s -> True - Cc | keep_hc -> True - _other -> False - - output_fn <- - (if phase == last_phase && not do_linking && use_ofile - then do o_file <- readIORef output_file - case o_file of - Just s -> return s - Nothing -> do - f <- odir_ify (orig_basename ++ '.':new_ext) - osuf_ify f - - -- .o files are always kept. .s files and .hc file may be kept. - else if keep_this_output - then odir_ify (orig_basename ++ '.':new_ext) - else do filename <- newTempName new_ext - add files_to_clean filename - return filename - ) + output_fn <- outputFileName (null phases) keep o_suffix - run_phase phase orig_basename input_fn output_fn + carry_on <- run_phase phase orig_basename orig_suffix input_fn output_fn + -- sometimes we bail out early, eg. when the compiler's recompilation + -- checker has determined that recompilation isn't necessary. + if not carry_on + then do let (_,keep,final_suffix) = last phases + ofile <- outputFileName True keep final_suffix + return ofile + else do -- carry on ... -- sadly, ghc -E is supposed to write the file to stdout. We -- generate .cpp, so we also have to cat the file here. - if (next_phase > last_phase && last_phase == Cpp) - then run_something "Dump pre-processed file to stdout" - ("cat " ++ output_fn) - else return () + when (null phases && phase == Cpp) $ + run_something "Dump pre-processed file to stdout" + ("cat " ++ output_fn) - run_pipeline last_phase do_linking use_ofile - orig_basename (next_phase, output_fn) + run_pipeline phases output_fn do_linking use_ofile orig_basename orig_suffix + where + outputFileName last_phase keep suffix + = do o_file <- readIORef output_file + if last_phase && not do_linking && use_ofile && isJust o_file + then case o_file of + Just s -> return s + Nothing -> error "outputFileName" + else if keep == Persistent + then do f <- odir_ify (orig_basename ++ '.':suffix) + osuf_ify f + else do filename <- newTempName suffix + add files_to_clean filename + return filename -- find a temporary name that doesn't already exist. newTempName :: String -> IO String newTempName extn = do x <- getProcessID - tmp_dir <- readIORef tmp_prefix + tmp_dir <- readIORef tmpdir findTempName tmp_dir x where findTempName tmp_dir x = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn - b <- fileExist filename + b <- doesFileExist filename if b then findTempName tmp_dir (x+1) else return filename ------------------------------------------------------------------------------- --- mkdependHS phase +-- mkdependHS + + -- flags +GLOBAL_VAR(dep_makefile, "Makefile", String); +GLOBAL_VAR(dep_include_prelude, False, Bool); +GLOBAL_VAR(dep_ignore_dirs, [], [String]); +GLOBAL_VAR(dep_suffixes, [], [String]); +GLOBAL_VAR(dep_warnings, True, Bool); + + -- global vars +GLOBAL_VAR(dep_makefile_hdl, error "dep_makefile_hdl", Maybe Handle); +GLOBAL_VAR(dep_tmp_file, error "dep_tmp_file", String); +GLOBAL_VAR(dep_tmp_hdl, error "dep_tmp_hdl", Handle); +GLOBAL_VAR(dep_dir_contents, error "dep_dir_contents", [(String,[String])]); + +depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies" +depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" + +-- for compatibility with the old mkDependHS, we accept options of the form +-- -optdep-f -optdep.depend, etc. +dep_opts = [ + ( "s", SepArg (add dep_suffixes) ), + ( "f", SepArg (writeIORef dep_makefile) ), + ( "w", NoArg (writeIORef dep_warnings False) ), + ( "-include-prelude", NoArg (writeIORef dep_include_prelude True) ), + ( "X", Prefix (addToDirList dep_ignore_dirs) ), + ( "-exclude-directory=", Prefix (addToDirList dep_ignore_dirs) ) + ] + +beginMkDependHS :: IO () +beginMkDependHS = do + + -- slurp in the mkdependHS-style options + flags <- getOpts opt_dep + _ <- processArgs dep_opts flags [] + + -- open a new temp file in which to stuff the dependency info + -- as we go along. + dep_file <- newTempName "dep" + add files_to_clean dep_file + writeIORef dep_tmp_file dep_file + tmp_hdl <- openFile dep_file WriteMode + writeIORef dep_tmp_hdl tmp_hdl + + -- open the makefile + makefile <- readIORef dep_makefile + exists <- doesFileExist makefile + if not exists + then do + writeIORef dep_makefile_hdl Nothing + return () -do_mkdependHS :: [String] -> [String] -> IO () -do_mkdependHS cmd_opts srcs = do - - -- # They're not (currently) needed, but we need to quote any -#include options - -- foreach (@Cmd_opts) { - -- s/-#include.*$/'$&'/g; - -- }; - - mkdependHS <- readIORef pgm_dep - mkdependHS_opts <- getOpts opt_dep - hs_src_cpp_opts <- readIORef hs_source_cpp_opts + else do + makefile_hdl <- openFile makefile ReadMode + writeIORef dep_makefile_hdl (Just makefile_hdl) + + -- slurp through until we get the magic start string, + -- copying the contents into dep_makefile + let slurp = do + l <- hGetLine makefile_hdl + if (l == depStartMarker) + then return () + else do hPutStrLn tmp_hdl l; slurp + + -- slurp through until we get the magic end marker, + -- throwing away the contents + let chuck = do + l <- hGetLine makefile_hdl + if (l == depEndMarker) + then return () + else chuck + + catchJust ioErrors slurp + (\e -> if isEOFError e then return () else ioError e) + catchJust ioErrors chuck + (\e -> if isEOFError e then return () else ioError e) + + + -- write the magic marker into the tmp file + hPutStrLn tmp_hdl depStartMarker + + -- cache the contents of all the import directories, for future + -- reference. + import_dirs <- readIORef import_paths + pkg_import_dirs <- getPackageImportPath + import_dir_contents <- mapM getDirectoryContents import_dirs + pkg_import_dir_contents <- mapM getDirectoryContents pkg_import_dirs + writeIORef dep_dir_contents + (zip import_dirs import_dir_contents ++ + zip pkg_import_dirs pkg_import_dir_contents) + + -- ignore packages unless --include-prelude is on + include_prelude <- readIORef dep_include_prelude + when (not include_prelude) $ + mapM_ (add dep_ignore_dirs) pkg_import_dirs + + return () + + +endMkDependHS :: IO () +endMkDependHS = do + makefile <- readIORef dep_makefile + makefile_hdl <- readIORef dep_makefile_hdl + tmp_file <- readIORef dep_tmp_file + tmp_hdl <- readIORef dep_tmp_hdl + + -- write the magic marker into the tmp file + hPutStrLn tmp_hdl depEndMarker + + case makefile_hdl of + Nothing -> return () + Just hdl -> do + + -- slurp the rest of the orignal makefile and copy it into the output + let slurp = do + l <- hGetLine hdl + hPutStrLn tmp_hdl l + slurp + + catchJust ioErrors slurp + (\e -> if isEOFError e then return () else ioError e) + + hClose hdl + + hClose tmp_hdl -- make sure it's flushed + + -- create a backup of the original makefile + when (isJust makefile_hdl) $ + run_something ("Backing up " ++ makefile) + (unwords [ "cp", makefile, makefile++".bak" ]) + + -- copy the new makefile in place + run_something "Installing new makefile" + (unwords [ "cp", tmp_file, makefile ]) + + +findDependency :: String -> Import -> IO (Maybe (String, Bool)) +findDependency mod imp = do + dir_contents <- readIORef dep_dir_contents + ignore_dirs <- readIORef dep_ignore_dirs + hisuf <- readIORef hi_suf + + let + (imp_mod, is_source) = + case imp of + Normal str -> (str, False) + Source str -> (str, True ) + + imp_hi = imp_mod ++ '.':hisuf + imp_hiboot = imp_mod ++ ".hi-boot" + imp_hiboot_v = imp_mod ++ ".hi-boot-" ++ cHscIfaceFileVersion + imp_hs = imp_mod ++ ".hs" + imp_lhs = imp_mod ++ ".lhs" + + deps | is_source = [ imp_hiboot_v, imp_hiboot, imp_hs, imp_lhs ] + | otherwise = [ imp_hi, imp_hs, imp_lhs ] + + search [] = throwDyn (OtherError ("can't find one of the following: " ++ + unwords (map (\d -> '`': d ++ "'") deps) ++ + " (imported from `" ++ mod ++ "')")) + search ((dir, contents) : dirs) + | null present = search dirs + | otherwise = + if dir `elem` ignore_dirs + then return Nothing + else if is_source + then if dep /= imp_hiboot_v + then return (Just (dir++'/':imp_hiboot, False)) + else return (Just (dir++'/':dep, False)) + else return (Just (dir++'/':imp_hi, not is_source)) + where + present = filter (`elem` contents) deps + dep = head present + + -- in + search dir_contents - run_something "Dependency generation" - (unwords (mkdependHS : - mkdependHS_opts - ++ hs_src_cpp_opts - ++ ("--" : cmd_opts ) - ++ ("--" : srcs) - )) ------------------------------------------------------------------------------- -- Unlit phase -run_phase Unlit basename input_fn output_fn +run_phase Unlit _basename _suff input_fn output_fn = do unlit <- readIORef pgm_L unlit_flags <- getOpts opt_L run_something "Literate pre-processor" ("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && " ++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn) + return True ------------------------------------------------------------------------------- -- Cpp phase -run_phase Cpp basename input_fn output_fn +run_phase Cpp _basename _suff input_fn output_fn = do src_opts <- getOptionsFromSource input_fn - processArgs src_opts [] + -- ToDo: this is *wrong* if we're processing more than one file: + -- the OPTIONS will persist through the subsequent compilations. + _ <- processArgs driver_opts src_opts [] - do_cpp <- readIORef cpp_flag + do_cpp <- readState cpp_flag if do_cpp then do cpp <- readIORef pgm_P @@ -1258,22 +1674,79 @@ run_phase Cpp basename input_fn output_fn ++ [ "-x", "c", input_fn, ">>", output_fn ] )) else do - run_something "Inefective C pre-processor" + run_something "Ineffective C pre-processor" ("echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}' > " ++ output_fn ++ " && cat " ++ input_fn ++ " >> " ++ output_fn) + return True ----------------------------------------------------------------------------- +-- MkDependHS phase + +run_phase MkDependHS basename suff input_fn _output_fn = do + src <- readFile input_fn + let imports = getImports src + + deps <- mapM (findDependency basename) imports + + osuf_opt <- readIORef output_suf + let osuf = case osuf_opt of + Nothing -> "o" + Just s -> s + + extra_suffixes <- readIORef dep_suffixes + let suffixes = osuf : map (++ ('_':osuf)) extra_suffixes + ofiles = map (\suf -> basename ++ '.':suf) suffixes + + objs <- mapM odir_ify ofiles + + hdl <- readIORef dep_tmp_hdl + + -- std dependeny of the object(s) on the source file + hPutStrLn hdl (unwords objs ++ " : " ++ basename ++ '.':suff) + + let genDep (dep, False {- not an hi file -}) = + hPutStrLn hdl (unwords objs ++ " : " ++ dep) + genDep (dep, True {- is an hi file -}) = do + hisuf <- readIORef hi_suf + let dep_base = remove_suffix '.' dep + deps = (dep_base ++ hisuf) + : map (\suf -> dep_base ++ suf ++ '_':hisuf) extra_suffixes + -- length objs should be == length deps + sequence_ (zipWith (\o d -> hPutStrLn hdl (o ++ " : " ++ d)) objs deps) + + mapM genDep [ d | Just d <- deps ] + + return True + +-- add the lines to dep_makefile: + -- always: + -- this.o : this.hs + + -- if the dependency is on something other than a .hi file: + -- this.o this.p_o ... : dep + -- otherwise + -- if the import is {-# SOURCE #-} + -- this.o this.p_o ... : dep.hi-boot[-$vers] + + -- else + -- this.o ... : dep.hi + -- this.p_o ... : dep.p_hi + -- ... + + -- (where .o is $osuf, and the other suffixes come from + -- the cmdline -s options). + +----------------------------------------------------------------------------- -- Hsc phase -run_phase Hsc basename input_fn output_fn +run_phase Hsc basename suff input_fn output_fn = do hsc <- readIORef pgm_C -- we add the current directory (i.e. the directory in which -- the .hs files resides) to the import path, since this is -- what gcc does, and it's probably what you want. - let (root,dir) = break (=='/') (reverse basename) - current_dir = if null dir then "." else reverse dir + let current_dir = getdir basename paths <- readIORef include_paths writeIORef include_paths (current_dir : paths) @@ -1281,16 +1754,6 @@ run_phase Hsc basename input_fn output_fn -- build the hsc command line hsc_opts <- build_hsc_opts - doing_hi <- readIORef produceHi - tmp_hi_file <- if doing_hi - then do fn <- newTempName "hi" - add files_to_clean fn - return fn - else return "" - - let hi_flag = if doing_hi then "-hifile=" ++ tmp_hi_file - else "" - -- deal with -Rghc-timing timing <- readIORef collect_ghc_timing stat_file <- newTempName "stat" @@ -1304,29 +1767,61 @@ run_phase Hsc basename input_fn output_fn add files_to_clean tmp_stub_h add files_to_clean tmp_stub_c + -- figure out where to put the .hi file + ohi <- readIORef output_hi + hisuf <- readIORef hi_suf + let hi_flags = case ohi of + Nothing -> [ "-hidir="++current_dir, "-hisuf="++hisuf ] + Just fn -> [ "-hifile="++fn ] + + -- figure out if the source has changed, for recompilation avoidance. + -- only do this if we're eventually going to generate a .o file. + -- (ToDo: do when generating .hc files too?) + -- + -- Setting source_unchanged to "-fsource_unchanged" means that M.o seems + -- to be up to date wrt M.hs; so no need to recompile unless imports have + -- changed (which the compiler itself figures out). + -- Setting source_unchanged to "" tells the compiler that M.o is out of + -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. + do_recomp <- readIORef recomp + todo <- readIORef v_todo + o_file <- odir_ify (basename ++ '.':phase_input_ext Ln) + source_unchanged <- + if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln )) + then return "" + else do t1 <- getModificationTime (basename ++ '.':suff) + o_file_exists <- doesFileExist o_file + if not o_file_exists + then return "" -- Need to recompile + else do t2 <- getModificationTime o_file + if t2 > t1 + then return "-fsource-unchanged" + else return "" + + -- run the compiler! run_something "Haskell Compiler" (unwords (hsc : input_fn : ( hsc_opts - ++ [ hi_flag, " -ofile="++output_fn ] - ++ [ "-F="++tmp_stub_c, "-FH="++tmp_stub_h ] + ++ hi_flags + ++ [ + source_unchanged, + "-ofile="++output_fn, + "-F="++tmp_stub_c, + "-FH="++tmp_stub_h + ] ++ stat_opts ))) - -- Copy the .hi file into the current dir if it changed - on doing_hi - (do ohi <- readIORef output_hi - hisuf <- readIORef hi_suf - let hi_target = case ohi of - Nothing -> basename ++ '.':hisuf - Just fn -> fn - new_hi_file <- fileExist tmp_hi_file - on new_hi_file - (run_something "Copy hi file" - (unwords ["mv", tmp_hi_file, hi_target])) - ) - + -- check whether compilation was performed, bail out if not + b <- doesFileExist output_fn + if not b && not (null source_unchanged) -- sanity + then do run_something "Touching object file" + ("touch " ++ o_file) + return False + else do -- carry on... + -- Generate -Rghc-timing info - on (timing) ( + when (timing) ( run_something "Generate timing stats" (findFile "ghc-stats" cGHC_STATS ++ ' ':stat_file) ) @@ -1336,13 +1831,13 @@ run_phase Hsc basename input_fn output_fn let stub_c = basename ++ "_stub.c" -- copy .h_stub file into current dir if present - b <- fileExist tmp_stub_h - on b (do + b <- doesFileExist tmp_stub_h + when b (do run_something "Copy stub .h file" ("cp " ++ tmp_stub_h ++ ' ':stub_h) -- #include <..._stub.h> in .hc file - add cmdline_hc_includes tmp_stub_h -- hack + addCmdlineHCInclude tmp_stub_h -- hack -- copy the _stub.c file into the current dir run_something "Copy stub .c file" @@ -1353,13 +1848,14 @@ run_phase Hsc basename input_fn output_fn ]) -- compile the _stub.c file w/ gcc - run_pipeline As False{-no linking-} + pipeline <- genPipeline (StopBefore Ln) "" stub_c + run_pipeline pipeline stub_c False{-no linking-} False{-no -o option-} - (basename++"_stub") - (Cc, stub_c) + (basename++"_stub") "c" add ld_inputs (basename++"_stub.o") ) + return True ----------------------------------------------------------------------------- -- Cc phase @@ -1367,12 +1863,11 @@ run_phase Hsc basename input_fn output_fn -- we don't support preprocessing .c files (with -E) now. Doing so introduces -- way too many hacks, and I can't say I've ever used it anyway. -run_phase cc_phase basename input_fn output_fn +run_phase cc_phase _basename _suff input_fn output_fn | cc_phase == Cc || cc_phase == HCc = do cc <- readIORef pgm_c - cc_opts <- getOpts opt_c + cc_opts <- (getOpts opt_c) cmdline_include_dirs <- readIORef include_paths - -- ToDo: $c_flags .= " -mno-cygwin" if ( $TargetPlatform =~ /-mingw32$/ ); let hcc = cc_phase == HCc @@ -1384,7 +1879,7 @@ run_phase cc_phase basename input_fn output_fn ++ pkg_include_dirs) c_includes <- getPackageCIncludes - cmdline_includes <- readIORef cmdline_hc_includes -- -#include options + cmdline_includes <- readState cmdline_hc_includes -- -#include options let cc_injects | hcc = unlines (map mk_include (c_includes ++ reverse cmdline_includes)) @@ -1416,6 +1911,8 @@ run_phase cc_phase basename input_fn output_fn pkg_extra_cc_opts <- getPackageExtraCcOpts + excessPrecision <- readState excess_precision + run_something "C Compiler" (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ] ++ md_c_flags @@ -1425,22 +1922,27 @@ run_phase cc_phase basename input_fn output_fn ++ [ verb, "-S", "-Wimplicit", opt_flag ] ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ] ++ cc_opts +#ifdef mingw32_TARGET_OS + ++ [" -mno-cygwin"] +#endif + ++ (if excessPrecision then [] else [ "-ffloat-store" ]) ++ include_paths ++ pkg_extra_cc_opts -- ++ [">", ccout] )) + return True -- ToDo: postprocess the output from gcc ----------------------------------------------------------------------------- -- Mangle phase -run_phase Mangle basename input_fn output_fn +run_phase Mangle _basename _suff input_fn output_fn = do mangler <- readIORef pgm_m mangler_opts <- getOpts opt_m machdep_opts <- if (prefixMatch "i386" cTARGETPLATFORM) - then do n_regs <- readIORef stolen_x86_regs + then do n_regs <- readState stolen_x86_regs return [ show n_regs ] else return [] run_something "Assembly Mangler" @@ -1449,15 +1951,16 @@ run_phase Mangle basename input_fn output_fn ++ [ input_fn, output_fn ] ++ machdep_opts )) + return True ----------------------------------------------------------------------------- -- Splitting phase -run_phase SplitMangle basename input_fn outputfn +run_phase SplitMangle _basename _suff input_fn _output_fn = do splitter <- readIORef pgm_s -- this is the prefix used for the split .s files - tmp_pfx <- readIORef tmp_prefix + tmp_pfx <- readIORef tmpdir x <- getProcessID let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x writeIORef split_prefix split_s_prefix @@ -1478,11 +1981,12 @@ run_phase SplitMangle basename input_fn outputfn s <- readFile n_files let n = read s :: Int writeIORef n_split_files n + return True ----------------------------------------------------------------------------- -- As phase -run_phase As basename input_fn output_fn +run_phase As _basename _suff input_fn output_fn = do as <- readIORef pgm_a as_opts <- getOpts opt_a @@ -1493,15 +1997,12 @@ run_phase As basename input_fn output_fn ++ cmdline_include_flags ++ [ "-c", input_fn, "-o", output_fn ] )) + return True -run_phase SplitAs basename input_fn output_fn +run_phase SplitAs basename _suff _input_fn _output_fn = do as <- readIORef pgm_a as_opts <- getOpts opt_a - odir_opt <- readIORef output_dir - let odir | Just s <- odir_opt = s - | otherwise = basename - split_s_prefix <- readIORef split_prefix n <- readIORef n_split_files @@ -1521,12 +2022,13 @@ run_phase SplitAs basename input_fn output_fn )) mapM_ assemble_file [1..n] + return True ----------------------------------------------------------------------------- -- Linking -do_link :: [String] -> [String] -> IO () -do_link o_files unknown_srcs = do +do_link :: [String] -> IO () +do_link o_files = do ln <- readIORef pgm_l verb <- is_verbose o_file <- readIORef output_file @@ -1539,7 +2041,7 @@ do_link o_files unknown_srcs = do let lib_path_opts = map ("-L"++) lib_paths pkg_libs <- getPackageLibraries - let pkg_lib_opts = map ("-l"++) pkg_libs + let pkg_lib_opts = map (\lib -> "-l"++lib) pkg_libs libs <- readIORef cmdline_libraries let lib_opts = map ("-l"++) (reverse libs) @@ -1550,18 +2052,20 @@ do_link o_files unknown_srcs = do -- probably _stub.o files extra_ld_inputs <- readIORef ld_inputs + -- opts from -optl- + extra_ld_opts <- getOpts opt_l + run_something "Linker" (unwords ([ ln, verb, "-o", output_fn ] - -- ToDo: -u options ++ o_files - ++ unknown_srcs ++ extra_ld_inputs ++ lib_path_opts ++ lib_opts ++ pkg_lib_path_opts ++ pkg_lib_opts ++ pkg_extra_ld_opts + ++ extra_ld_opts ) ) @@ -1571,24 +2075,33 @@ do_link o_files unknown_srcs = do run_something phase_name cmd = do verb <- readIORef verbose - if verb then do + when verb $ do putStr phase_name putStrLn ":" putStrLn cmd - else - return () + hFlush stdout -- test for -n flag n <- readIORef dry_run - if n then return () else do + unless n $ do -- and run it! - exit_code <- system cmd `catchAllIO` +#ifndef mingw32_TARGET_OS + exit_code <- system cmd `catchAllIO` + (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1))) +#else + tmp <- newTempName "sh" + h <- openFile tmp WriteMode + hPutStrLn h cmd + hClose h + exit_code <- system ("sh - " ++ tmp) `catchAllIO` (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1))) + removeFile tmp +#endif if exit_code /= ExitSuccess then throwDyn (PhaseFailed phase_name exit_code) - else do on verb (putStr "\n") + else do when verb (putStr "\n") return () ----------------------------------------------------------------------------- @@ -1607,17 +2120,17 @@ data OptKind -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override -- flags further down the list with the same prefix. -opts = +driver_opts = [ ------- help ------------------------------------------------------- ( "?" , NoArg long_usage) , ( "-help" , NoArg long_usage) ------- version ---------------------------------------------------- - , ( "-version" , NoArg (do hPutStrLn stderr (cProjectName + , ( "-version" , NoArg (do hPutStrLn stdout (cProjectName ++ ", version " ++ version_str) exitWith ExitSuccess)) - , ( "-numeric-version", NoArg (do hPutStrLn stderr version_str + , ( "-numeric-version", NoArg (do hPutStrLn stdout version_str exitWith ExitSuccess)) ------- verbosity ---------------------------------------------------- @@ -1631,6 +2144,7 @@ opts = ------- ways -------------------------------------------------------- , ( "prof" , NoArg (addNoDups ways WayProf) ) , ( "unreg" , NoArg (addNoDups ways WayUnreg) ) + , ( "dll" , NoArg (addNoDups ways WayDll) ) , ( "ticky" , NoArg (addNoDups ways WayTicky) ) , ( "parallel" , NoArg (addNoDups ways WayPar) ) , ( "gransim" , NoArg (addNoDups ways WayGran) ) @@ -1648,15 +2162,20 @@ opts = --"hi-with-*" -> hiw <- readIORef hi_with (ToDo) --------- Profiling -------------------------------------------------- - , ( "auto-dicts" , NoArg (add opt_C "-fauto-sccs-on-dicts") ) - , ( "auto-all" , NoArg (add opt_C "-fauto-sccs-on-all-toplevs") ) - , ( "auto" , NoArg (add opt_C "-fauto-sccs-on-exported-toplevs") ) - , ( "caf-all" , NoArg (add opt_C "-fauto-sccs-on-individual-cafs") ) + , ( "auto-dicts" , NoArg (addOpt_C "-fauto-sccs-on-dicts") ) + , ( "auto-all" , NoArg (addOpt_C "-fauto-sccs-on-all-toplevs") ) + , ( "auto" , NoArg (addOpt_C "-fauto-sccs-on-exported-toplevs") ) + , ( "caf-all" , NoArg (addOpt_C "-fauto-sccs-on-individual-cafs") ) -- "ignore-sccs" doesn't work (ToDo) + , ( "no-auto-dicts" , NoArg (addAntiOpt_C "-fauto-sccs-on-dicts") ) + , ( "no-auto-all" , NoArg (addAntiOpt_C "-fauto-sccs-on-all-toplevs") ) + , ( "no-auto" , NoArg (addAntiOpt_C "-fauto-sccs-on-exported-toplevs") ) + , ( "no-caf-all" , NoArg (addAntiOpt_C "-fauto-sccs-on-individual-cafs") ) + ------- Miscellaneous ----------------------------------------------- - , ( "cpp" , NoArg (writeIORef cpp_flag True) ) - , ( "#include" , HasArg (add cmdline_hc_includes) ) + , ( "cpp" , NoArg (updateState (\s -> s{ cpp_flag = True })) ) + , ( "#include" , HasArg (addCmdlineHCInclude) ) , ( "no-link-chk" , NoArg (return ()) ) -- ignored for backwards compat ------- Output Redirection ------------------------------------------ @@ -1664,7 +2183,7 @@ opts = , ( "o" , SepArg (writeIORef output_file . Just) ) , ( "osuf" , HasArg (writeIORef output_suf . Just) ) , ( "hisuf" , HasArg (writeIORef hi_suf) ) - , ( "tmpdir" , HasArg (writeIORef tmp_prefix . (++ "/")) ) + , ( "tmpdir" , HasArg (writeIORef tmpdir . (++ "/")) ) , ( "ohi" , HasArg (\s -> case s of "-" -> writeIORef hi_on_stdout True _ -> writeIORef output_hi (Just s)) ) @@ -1673,33 +2192,36 @@ opts = , ( "keep-hc-file" , AnySuffix (\_ -> writeIORef keep_hc_files True) ) , ( "keep-s-file" , AnySuffix (\_ -> writeIORef keep_s_files True) ) , ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef keep_raw_s_files True) ) + , ( "keep-tmp-files" , AnySuffix (\_ -> writeIORef keep_tmp_files True) ) , ( "split-objs" , NoArg (if can_split then do writeIORef split_object_files True - writeIORef hsc_lang HscC - add opt_C "-fglobalise-toplev-names" - add opt_c "-DUSE_SPLIT_MARKERS" + addOpt_C "-fglobalise-toplev-names" + addOpt_c "-DUSE_SPLIT_MARKERS" else hPutStrLn stderr "warning: don't know how to split \ \object files on this architecture" ) ) ------- Include/Import Paths ---------------------------------------- - , ( "i" , OptPrefix augment_import_paths ) - , ( "I" , Prefix augment_include_paths ) + , ( "i" , OptPrefix (addToDirList import_paths) ) + , ( "I" , Prefix (addToDirList include_paths) ) ------- Libraries --------------------------------------------------- - , ( "L" , Prefix augment_library_paths ) + , ( "L" , Prefix (addToDirList library_paths) ) , ( "l" , Prefix (add cmdline_libraries) ) ------- Packages ---------------------------------------------------- - , ( "package-name" , HasArg (\s -> add opt_C ("-inpackage="++s)) ) + , ( "package-name" , HasArg (\s -> addOpt_C ("-inpackage="++s)) ) , ( "package" , HasArg (addPackage) ) , ( "syslib" , HasArg (addPackage) ) -- for compatibility w/ old vsns + , ( "-list-packages" , NoArg (listPackages) ) + , ( "-add-package" , NoArg (newPackage) ) + , ( "-delete-package" , SepArg (deletePackage) ) + ------- Specific phases -------------------------------------------- - , ( "pgmdep" , HasArg (writeIORef pgm_dep) ) , ( "pgmL" , HasArg (writeIORef pgm_L) ) , ( "pgmP" , HasArg (writeIORef pgm_P) ) , ( "pgmC" , HasArg (writeIORef pgm_C) ) @@ -1709,59 +2231,60 @@ opts = , ( "pgma" , HasArg (writeIORef pgm_a) ) , ( "pgml" , HasArg (writeIORef pgm_l) ) - , ( "optdep" , HasArg (add opt_dep) ) - , ( "optL" , HasArg (add opt_L) ) - , ( "optP" , HasArg (add opt_P) ) - , ( "optCrts" , HasArg (add opt_Crts) ) - , ( "optC" , HasArg (add opt_C) ) - , ( "optc" , HasArg (add opt_c) ) - , ( "optm" , HasArg (add opt_m) ) - , ( "opta" , HasArg (add opt_a) ) - , ( "optl" , HasArg (add opt_l) ) - , ( "optdll" , HasArg (add opt_dll) ) + , ( "optdep" , HasArg (addOpt_dep) ) + , ( "optL" , HasArg (addOpt_L) ) + , ( "optP" , HasArg (addOpt_P) ) + , ( "optCrts" , HasArg (addOpt_Crts) ) + , ( "optC" , HasArg (addOpt_C) ) + , ( "optc" , HasArg (addOpt_c) ) + , ( "optm" , HasArg (addOpt_m) ) + , ( "opta" , HasArg (addOpt_a) ) + , ( "optl" , HasArg (addOpt_l) ) + , ( "optdll" , HasArg (addOpt_dll) ) ------ HsCpp opts --------------------------------------------------- - , ( "D" , Prefix (\s -> add opt_P ("-D'"++s++"'") ) ) - , ( "U" , Prefix (\s -> add opt_P ("-U'"++s++"'") ) ) + , ( "D" , Prefix (\s -> addOpt_P ("-D'"++s++"'") ) ) + , ( "U" , Prefix (\s -> addOpt_P ("-U'"++s++"'") ) ) ------ Warning opts ------------------------------------------------- - , ( "W" , NoArg (writeIORef warning_opt W_)) - , ( "Wall" , NoArg (writeIORef warning_opt W_all)) - , ( "Wnot" , NoArg (writeIORef warning_opt W_not)) - , ( "w" , NoArg (writeIORef warning_opt W_not)) + , ( "W" , NoArg (updateState (\s -> s{ warning_opt = W_ }))) + , ( "Wall" , NoArg (updateState (\s -> s{ warning_opt = W_all }))) + , ( "Wnot" , NoArg (updateState (\s -> s{ warning_opt = W_not }))) + , ( "w" , NoArg (updateState (\s -> s{ warning_opt = W_not }))) ----- Linker -------------------------------------------------------- , ( "static" , NoArg (writeIORef static True) ) ------ Compiler RTS options ----------------------------------------- - , ( "H" , HasArg (sizeOpt specific_heap_size) ) - , ( "K" , HasArg (sizeOpt specific_stack_size) ) + , ( "H" , HasArg (newHeapSize . decodeSize) ) + , ( "K" , HasArg (newStackSize . decodeSize) ) , ( "Rscale-sizes" , HasArg (floatOpt scale_sizes_by) ) - , ( "Rghc-timing" , NoArg (writeIORef collect_ghc_timing True) ) + , ( "Rghc-timing" , NoArg (writeIORef collect_ghc_timing True) ) ------ Debugging ---------------------------------------------------- , ( "dstg-stats" , NoArg (writeIORef opt_StgStats True) ) - , ( "dno-" , Prefix (\s -> add anti_opt_C ("-d"++s)) ) - , ( "d" , AnySuffix (add opt_C) ) + , ( "dno-" , Prefix (\s -> addAntiOpt_C ("-d"++s)) ) + , ( "d" , AnySuffix (addOpt_C) ) ------ Machine dependant (-m) stuff --------------------------- - , ( "monly-2-regs", NoArg (writeIORef stolen_x86_regs 2) ) - , ( "monly-3-regs", NoArg (writeIORef stolen_x86_regs 3) ) - , ( "monly-4-regs", NoArg (writeIORef stolen_x86_regs 4) ) + , ( "monly-2-regs", NoArg (updateState (\s -> s{stolen_x86_regs = 2}) )) + , ( "monly-3-regs", NoArg (updateState (\s -> s{stolen_x86_regs = 3}) )) + , ( "monly-4-regs", NoArg (updateState (\s -> s{stolen_x86_regs = 4}) )) ------ Compiler flags ----------------------------------------------- , ( "O2-for-C" , NoArg (writeIORef opt_minus_o2_for_C True) ) , ( "O" , OptPrefix (setOptLevel) ) - , ( "fglasgow-exts-no-lang", NoArg ( do add opt_C "-fglasgow-exts") ) + , ( "fglasgow-exts-no-lang", NoArg ( do addOpt_C "-fglasgow-exts") ) - , ( "fglasgow-exts" , NoArg (do add opt_C "-fglasgow-exts" + , ( "fglasgow-exts" , NoArg (do addOpt_C "-fglasgow-exts" addPackage "lang")) , ( "fasm" , OptPrefix (\_ -> writeIORef hsc_lang HscAsm) ) + , ( "fvia-c" , NoArg (writeIORef hsc_lang HscC) ) , ( "fvia-C" , NoArg (writeIORef hsc_lang HscC) ) , ( "fno-asm-mangling" , NoArg (writeIORef do_asm_mangling False) ) @@ -1769,60 +2292,65 @@ opts = , ( "fmax-simplifier-iterations", Prefix (writeIORef opt_MaxSimplifierIterations . read) ) - , ( "fusagesp", NoArg (do writeIORef opt_UsageSPInf True - add opt_C "-fusagesp-on") ) + , ( "fusagesp" , NoArg (do writeIORef opt_UsageSPInf True + addOpt_C "-fusagesp-on") ) + + , ( "fexcess-precision" , NoArg (do updateState + (\s -> s{ excess_precision = True }) + addOpt_C "-fexcess-precision")) -- flags that are "active negatives" - , ( "fno-implicit-prelude" , PassFlag (add opt_C) ) - , ( "fno-prune-tydecls" , PassFlag (add opt_C) ) - , ( "fno-prune-instdecls" , PassFlag (add opt_C) ) - , ( "fno-pre-inlining" , PassFlag (add opt_C) ) + , ( "fno-implicit-prelude" , PassFlag (addOpt_C) ) + , ( "fno-prune-tydecls" , PassFlag (addOpt_C) ) + , ( "fno-prune-instdecls" , PassFlag (addOpt_C) ) + , ( "fno-pre-inlining" , PassFlag (addOpt_C) ) -- All other "-fno-" options cancel out "-f" on the hsc cmdline - , ( "fno-", Prefix (\s -> add anti_opt_C ("-f"++s)) ) + , ( "fno-", Prefix (\s -> addAntiOpt_C ("-f"++s)) ) -- Pass all remaining "-f" options to hsc - , ( "f", AnySuffix (add opt_C) ) + , ( "f", AnySuffix (addOpt_C) ) ] ----------------------------------------------------------------------------- -- Process command-line -processArgs :: [String] -> [String] -> IO [String] -- returns spare args -processArgs [] spare = return (reverse spare) -processArgs args@(('-':_):_) spare = do - args' <- processOneArg args - processArgs args' spare -processArgs (arg:args) spare = - processArgs args (arg:spare) - -processOneArg :: [String] -> IO [String] -processOneArg (('-':arg):args) = do - let (rest,action) = findArg arg +processArgs :: [(String,OptKind)] -> [String] -> [String] + -> IO [String] -- returns spare args +processArgs _spec [] spare = return (reverse spare) +processArgs spec args@(('-':_):_) spare = do + args' <- processOneArg spec args + processArgs spec args' spare +processArgs spec (arg:args) spare = + processArgs spec args (arg:spare) + +processOneArg :: [(String,OptKind)] -> [String] -> IO [String] +processOneArg spec (('-':arg):args) = do + let (rest,action) = findArg spec arg dash_arg = '-':arg case action of NoArg io -> if rest == "" then io >> return args - else throwDyn (UnknownFlag dash_arg) + else unknownFlagErr dash_arg HasArg fio -> if rest /= "" then fio rest >> return args else case args of - [] -> throwDyn (UnknownFlag dash_arg) + [] -> unknownFlagErr dash_arg (arg1:args1) -> fio arg1 >> return args1 SepArg fio -> case args of - [] -> throwDyn (UnknownFlag dash_arg) + [] -> unknownFlagErr dash_arg (arg1:args1) -> fio arg1 >> return args1 Prefix fio -> if rest /= "" then fio rest >> return args - else throwDyn (UnknownFlag dash_arg) + else unknownFlagErr dash_arg OptPrefix fio -> fio rest >> return args @@ -1830,15 +2358,15 @@ processOneArg (('-':arg):args) = do PassFlag fio -> if rest /= "" - then throwDyn (UnknownFlag dash_arg) + then unknownFlagErr dash_arg else fio ('-':arg) >> return args -findArg :: String -> (String,OptKind) -findArg arg - = case [ (remove_spaces rest, k) | (pat,k) <- opts, +findArg :: [(String,OptKind)] -> String -> (String,OptKind) +findArg spec arg + = case [ (remove_spaces rest, k) | (pat,k) <- spec, Just rest <- [my_prefix_match pat arg], is_prefix k || null rest ] of - [] -> throwDyn (UnknownFlag ('-':arg)) + [] -> unknownFlagErr ('-':arg) (one:_) -> one is_prefix (NoArg _) = False @@ -1849,24 +2377,17 @@ is_prefix _ = True ----------------------------------------------------------------------------- -- convert sizes like "3.5M" into integers -sizeOpt :: IORef Integer -> String -> IO () -sizeOpt ref str - | c == "" = writeSizeOpt ref (truncate n) - | c == "K" || c == "k" = writeSizeOpt ref (truncate (n * 1000)) - | c == "M" || c == "m" = writeSizeOpt ref (truncate (n * 1000 * 1000)) - | c == "G" || c == "g" = writeSizeOpt ref (truncate (n * 1000 * 1000 * 1000)) - | otherwise = throwDyn (UnknownFlag str) +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 (OtherError ("can't decode size: " ++ str)) where (m, c) = span pred str n = read m :: Double pred c = isDigit c || c == '.' -writeSizeOpt :: IORef Integer -> Integer -> IO () -writeSizeOpt ref new = do - current <- readIORef ref - if (new > current) - then writeIORef ref new - else return () - floatOpt :: IORef Double -> String -> IO () floatOpt ref str = writeIORef ref (read str :: Double) @@ -1890,7 +2411,7 @@ findFile name alt_path = unsafePerformIO (do top_dir <- readIORef topDir let installed_file = top_dir ++ '/':name let inplace_file = top_dir ++ '/':cCURRENT_DIR ++ '/':alt_path - b <- fileExist inplace_file + b <- doesFileExist inplace_file if b then return inplace_file else return installed_file ) @@ -1898,24 +2419,24 @@ findFile name alt_path = unsafePerformIO (do ----------------------------------------------------------------------------- -- Utils -my_partition :: (a -> Maybe b) -> [a] -> ([b],[a]) -my_partition p [] = ([],[]) +my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a]) +my_partition _ [] = ([],[]) my_partition p (a:as) = let (bs,cs) = my_partition p as in case p a of Nothing -> (bs,a:cs) - Just b -> (b:bs,cs) + Just b -> ((a,b):bs,cs) my_prefix_match :: String -> String -> Maybe String my_prefix_match [] rest = Just rest -my_prefix_match (p:pat) [] = Nothing +my_prefix_match (_:_) [] = Nothing my_prefix_match (p:pat) (r:rest) | p == r = my_prefix_match pat rest | otherwise = Nothing prefixMatch :: Eq a => [a] -> [a] -> Bool -prefixMatch [] str = True -prefixMatch pat [] = False +prefixMatch [] _str = True +prefixMatch _pat [] = False prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss | otherwise = False @@ -1924,17 +2445,19 @@ postfixMatch pat str = prefixMatch (reverse pat) (reverse str) later = flip finally -on b io = if b then io >> return (error "on") else return (error "on") - -my_catch = flip catchAllIO my_catchDyn = flip catchDyn global :: a -> IORef a global a = unsafePerformIO (newIORef a) -split_filename :: String -> (String,String) -split_filename f = (reverse rev_basename, reverse rev_ext) - where (rev_ext, '.':rev_basename) = span ('.' /=) (reverse f) +splitFilename :: String -> (String,String) +splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext) + where (rev_ext, rev_basename) = span ('.' /=) (reverse f) + stripDot ('.':xs) = xs + stripDot xs = xs + +suffixOf :: String -> String +suffixOf s = drop_longest_prefix s '.' split :: Char -> String -> [String] split c s = case rest of @@ -1950,27 +2473,40 @@ add var x = do addNoDups :: Eq a => IORef [a] -> a -> IO () addNoDups var x = do xs <- readIORef var - if x `elem` xs then return () else writeIORef var (x:xs) + unless (x `elem` xs) $ writeIORef var (x:xs) -remove_suffix :: String -> Char -> String -remove_suffix s c +remove_suffix :: Char -> String -> String +remove_suffix c s | null pre = reverse suf | otherwise = reverse pre where (suf,pre) = break (==c) (reverse s) drop_longest_prefix :: String -> Char -> String drop_longest_prefix s c = reverse suf - where (suf,pre) = break (==c) (reverse s) + where (suf,_pre) = break (==c) (reverse s) take_longest_prefix :: String -> Char -> String take_longest_prefix s c = reverse pre - where (suf,pre) = break (==c) (reverse s) + where (_suf,pre) = break (==c) (reverse s) newsuf :: String -> String -> String -newsuf suf s = remove_suffix s '.' ++ suf +newsuf suf s = remove_suffix '.' s ++ suf + +-- getdir strips the filename off the input string, returning the directory. +getdir :: String -> String +getdir s = if null dir then "." else init dir + where dir = take_longest_prefix s '/' newdir :: String -> String -> String newdir dir s = dir ++ '/':drop_longest_prefix s '/' remove_spaces :: String -> String remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +----------------------------------------------------------------------------- +-- compatibility code + +#if __GLASGOW_HASKELL__ <= 408 +catchJust = catchIO +ioErrors = justIoErrors +#endif