X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fdriver%2FMain.hs;h=2e235bf8ee15ed58b4cdebfdcada8df527b31475;hb=55416377cceff0d81f6bcd06391f605cba1868cc;hp=b40d18b59d0a3bab8a0073defb9c1dd06a57d655;hpb=efc238188e61add0cd2e4c3b82d93f534e14236c;p=ghc-hetmet.git diff --git a/ghc/driver/Main.hs b/ghc/driver/Main.hs index b40d18b..2e235bf 100644 --- a/ghc/driver/Main.hs +++ b/ghc/driver/Main.hs @@ -1,4 +1,7 @@ +{-# 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 @@ -10,6 +13,7 @@ module Main (main) where +import GetImports import Package import Config @@ -25,7 +29,6 @@ import Dynamic import IO import Monad -import Array import List import System import Maybe @@ -42,6 +45,8 @@ 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 @@ -68,9 +73,7 @@ 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_file = "ghc-usage.txt" @@ -83,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 @@ -115,24 +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 - | OtherError String + | 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) @@ -143,27 +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 (OtherError str) - = showString str +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 [] @@ -182,43 +259,18 @@ cleanTempFiles = do 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 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__="++cHaskell1Version , "-D__GLASGOW_HASKELL__="++cProjectVersionInt @@ -226,26 +278,21 @@ hs_source_cpp_opts = global , "-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(tmpdir, cDEFAULT_TMPDIR, String) #if !defined(HAVE_WIN32_DLL_SUPPORT) || defined(DONT_WANT_WIN32_DLL_SUPPORT) GLOBAL_VAR(static, True, Bool) #else @@ -253,7 +300,6 @@ GLOBAL_VAR(static, False, Bool) #endif GLOBAL_VAR(collect_ghc_timing, False, Bool) GLOBAL_VAR(do_asm_mangling, True, Bool) -GLOBAL_VAR(excess_precision, False, Bool) ----------------------------------------------------------------------------- -- Splitting object files (for libraries) @@ -279,6 +325,7 @@ data HscLang = HscC | HscAsm | HscJava + deriving Eq GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" && (prefixMatch "i386" cTARGETPLATFORM || @@ -349,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 @@ -366,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 @@ -462,7 +508,6 @@ hsc_minusO_flags = do "-fmax-simplifier-iterations2", "]", - "-fsimplify", "[", "-fmax-simplifier-iterations2", @@ -473,6 +518,7 @@ hsc_minusO_flags = do "-fstrictness", "-fcpr-analyse", "-fworker-wrapper", + "-fglom-binds", "-fsimplify", "[", @@ -528,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]) @@ -536,24 +582,11 @@ 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 @@ -573,12 +606,12 @@ newPackage = do details <- readIORef package_details hPutStr stdout "Reading package info from stdin... " stuff <- getContents - let new_pkg = read stuff :: (String,Package) + let new_pkg = read stuff :: Package catchAll new_pkg - (\e -> throwDyn (OtherError "parse error in package info")) + (\_ -> throwDyn (OtherError "parse error in package info")) hPutStrLn stdout "done." - if (fst new_pkg `elem` map fst details) - then throwDyn (OtherError ("package `" ++ fst new_pkg ++ + if (name new_pkg `elem` map name details) + then throwDyn (OtherError ("package `" ++ name new_pkg ++ "' already installed")) else do conf_file <- readIORef package_config @@ -591,13 +624,13 @@ deletePackage :: String -> IO () deletePackage pkg = do checkConfigAccess details <- readIORef package_details - if (pkg `notElem` map fst 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) . fst)) + writeNewConfig conf_file (filter ((/= pkg) . name)) exitWith ExitSuccess checkConfigAccess :: IO () @@ -618,7 +651,7 @@ maybeRestoreOldConfig conf_file io throw e ) -writeNewConfig :: String -> ([(String,Package)] -> [(String,Package)]) -> IO () +writeNewConfig :: String -> ([Package] -> [Package]) -> IO () writeNewConfig conf_file fn = do hPutStr stdout "Writing new package config file... " old_details <- readIORef package_details @@ -644,8 +677,8 @@ 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 unless (package `elem` ps) $ do @@ -661,7 +694,7 @@ getPackageImportPath = do getPackageIncludePath :: IO [String] getPackageIncludePath = do - ps <- readIORef packages + ps <- readIORef packages ps' <- getPackageDetails ps return (nub (filter (not.null) (concatMap include_dirs ps'))) @@ -709,9 +742,15 @@ getPackageExtraLdOpts = do getPackageDetails :: [String] -> IO [Package] getPackageDetails ps = do pkg_details <- readIORef package_details - return [ pkg | p <- ps, Just pkg <- [ lookup p pkg_details ] ] + return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ] -GLOBAL_VAR(package_details, (error "package_details"), [(String,Package)]) +GLOBAL_VAR(package_details, (error "package_details"), [Package]) + +lookupPkg :: String -> [Package] -> Maybe Package +lookupPkg nm ps + = case [p | p <- ps, name p == nm] of + [] -> Nothing + (p:_) -> Just p ----------------------------------------------------------------------------- -- Ways @@ -780,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 @@ -824,16 +866,14 @@ way_details = [ ]), (WayPar, Way "mp" "Parallel" - [ "-fstack-check" - , "-fparallel" + [ "-fparallel" , "-D__PARALLEL_HASKELL__" , "-optc-DPAR" , "-package concurrent" , "-fvia-C" ]), (WayGran, Way "mg" "Gransim" - [ "-fstack-check" - , "-fgransim" + [ "-fgransim" , "-D__GRANSIM__" , "-optc-DGRAN" , "-package concurrent" @@ -868,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) @@ -879,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 @@ -931,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", @@ -955,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 @@ -969,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 @@ -1014,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 @@ -1054,19 +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 "#" l -> look h - | prefixMatch "{-# LINE" 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 @@ -1074,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, @@ -1138,69 +1125,108 @@ main = 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 + -- 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 [] - -- get the -v flag + -- get the -v flag verb <- readIORef verbose when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file)) - if stop_phase == MkDependHS -- mkdependHS is special - then do_mkdependHS flags2 srcs - else do + -- 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 - 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 src_pipelines - o_files <- mapM compileFile phase_srcs + when (todo == DoMkDependHS) endMkDependHS - when do_linking $ - do_link o_files unknown_srcs + when (todo == DoLink) (do_link o_files) +----------------------------------------------------------------------------- +-- 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 + +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 @@ -1214,103 +1240,211 @@ 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 | split -> SplitMangle - | otherwise -> 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 - HCc | keep_hc -> True - _other -> False - - output_fn <- - (if next_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. - when (next_phase > last_phase && last_phase == Cpp) $ + 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 @@ -1319,44 +1453,205 @@ newTempName extn = do else return filename ------------------------------------------------------------------------------- --- mkdependHS phase - -do_mkdependHS :: [String] -> [String] -> IO () -do_mkdependHS cmd_opts srcs = do - -- HACK - let quote_include_opt o | prefixMatch "-#include" o = "'" ++ o ++ "'" - | otherwise = o - - mkdependHS <- readIORef pgm_dep - mkdependHS_opts <- getOpts opt_dep - hs_src_cpp_opts <- readIORef hs_source_cpp_opts - - run_something "Dependency generation" - (unwords (mkdependHS : - mkdependHS_opts - ++ hs_src_cpp_opts - ++ ("--" : map quote_include_opt cmd_opts ) - ++ ("--" : srcs) - )) +-- 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 () + + 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 + ------------------------------------------------------------------------------- -- 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 @@ -1379,15 +1674,73 @@ 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 @@ -1401,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" @@ -1431,12 +1774,37 @@ run_phase Hsc basename input_fn output_fn 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_flags ++ [ + source_unchanged, "-ofile="++output_fn, "-F="++tmp_stub_c, "-FH="++tmp_stub_h @@ -1444,8 +1812,16 @@ run_phase Hsc basename input_fn output_fn ++ stat_opts ))) + -- 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) ) @@ -1456,12 +1832,12 @@ run_phase Hsc basename input_fn output_fn -- copy .h_stub file into current dir if present b <- doesFileExist tmp_stub_h - on b (do + 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" @@ -1472,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 @@ -1486,7 +1863,7 @@ 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) @@ -1502,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)) @@ -1534,7 +1911,7 @@ run_phase cc_phase basename input_fn output_fn pkg_extra_cc_opts <- getPackageExtraCcOpts - excessPrecision <- readIORef excess_precision + excessPrecision <- readState excess_precision run_something "C Compiler" (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ] @@ -1553,18 +1930,19 @@ run_phase cc_phase basename input_fn output_fn ++ 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" @@ -1573,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 @@ -1602,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 @@ -1617,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 @@ -1645,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 @@ -1681,7 +2059,6 @@ do_link o_files unknown_srcs = do (unwords ([ ln, verb, "-o", output_fn ] ++ o_files - ++ unknown_srcs ++ extra_ld_inputs ++ lib_path_opts ++ lib_opts @@ -1711,7 +2088,7 @@ run_something phase_name cmd -- and run it! #ifndef mingw32_TARGET_OS exit_code <- system cmd `catchAllIO` - (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1))) + (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1))) #else tmp <- newTempName "sh" h <- openFile tmp WriteMode @@ -1724,7 +2101,7 @@ run_something phase_name cmd if exit_code /= ExitSuccess then throwDyn (PhaseFailed phase_name exit_code) - else do on verb (putStr "\n") + else do when verb (putStr "\n") return () ----------------------------------------------------------------------------- @@ -1743,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 ---------------------------------------------------- @@ -1785,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 ------------------------------------------ @@ -1801,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)) ) @@ -1814,23 +2196,23 @@ opts = , ( "split-objs" , NoArg (if can_split then do writeIORef split_object_files True - 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 @@ -1840,7 +2222,6 @@ opts = , ( "-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) ) @@ -1850,55 +2231,55 @@ 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) ) @@ -1912,62 +2293,64 @@ opts = Prefix (writeIORef opt_MaxSimplifierIterations . read) ) , ( "fusagesp" , NoArg (do writeIORef opt_UsageSPInf True - add opt_C "-fusagesp-on") ) + addOpt_C "-fusagesp-on") ) - , ( "fexcess-precision" , NoArg (do writeIORef excess_precision True - add opt_C "-fexcess-precision")) + , ( "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 @@ -1975,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 @@ -1994,23 +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 - when (new > current) $ - writeIORef ref new - floatOpt :: IORef Double -> String -> IO () floatOpt ref str = writeIORef ref (read str :: Double) @@ -2042,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 @@ -2068,20 +2445,20 @@ 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 (stripDot rev_basename), reverse rev_ext) +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 [] -> [chunk] @@ -2098,22 +2475,22 @@ addNoDups var x = do xs <- readIORef var 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 @@ -2125,3 +2502,11 @@ 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