X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FMain.hs;h=fb1556c49926efeca7ba20add36bcb79954ffcdc;hb=d6afbe3ebd127ece764bc943c015e74290318b6a;hp=dee1e1181ead620da105cf50de28f4fa7025aea3;hpb=7100c98bd87995bc769f1afec6e0650219631723;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index dee1e11..fb1556c 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,6 +1,7 @@ -{-# OPTIONS -W -fno-warn-incomplete-patterns #-} +{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} + ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.1 2000/10/10 13:25:19 simonmar Exp $ +-- $Id: Main.hs,v 1.91 2001/11/03 01:30:42 sof Exp $ -- -- GHC Driver program -- @@ -13,42 +14,90 @@ module Main (main) where -import CmSummarise ( getImports ) -import CmStaticInfo ( Package(..) ) -import TmpFiles -import Config +#include "HsVersions.h" -import RegexString -import Concurrent -#ifndef mingw32_TARGET_OS -import Posix + +#ifdef GHCI +import InteractiveUI(ghciWelcomeMsg, interactiveUI) #endif -import Directory -import IOExts -import Exception -import Dynamic + +import Finder ( initFinder ) +import CompManager ( cmInit, cmLoadModule ) +import HscTypes ( GhciMode(..) ) +import Config ( cBooterVersion, cGhcUnregisterised, cProjectVersion ) +import SysTools ( getPackageConfigPath, initSysTools, cleanTempFiles ) +import Packages ( showPackages ) + +import DriverPipeline ( GhcMode(..), doLink, doMkDLL, genPipeline, + getGhcMode, pipeLoop, v_GhcMode + ) +import DriverState ( buildCoreToDo, buildStgToDo, defaultHscLang, + findBuildTag, getPackageInfo, unregFlags, + v_Cmdline_libraries, v_Keep_tmp_files, v_Ld_inputs, + v_OptLevel, v_Output_file, v_Output_hi, + v_Package_details, v_Ways, getPackageExtraGhcOpts, + readPackageConf + ) +import DriverFlags ( dynFlag, buildStaticHscOpts, dynamic_flags, + processArgs, static_flags) + +import DriverMkDepend ( beginMkDependHS, endMkDependHS ) +import DriverPhases ( Phase(HsPp, Hsc, HCc), haskellish_src_file, objish_file ) + +import DriverUtil ( add, handle, handleDyn, later, splitFilename, + unknownFlagErr, getFileSuffix ) +import CmdLineOpts ( dynFlag, defaultDynFlags, restoreDynFlags, + saveDynFlags, setDynFlags, + DynFlags(..), HscLang(..), v_Static_hsc_opts + ) + +import Outputable +import Util +import Panic ( GhcException(..), panic ) + +-- Standard Haskell libraries import IO +import Directory ( doesFileExist ) +import IOExts ( readIORef, writeIORef ) +import Exception ( throwDyn, Exception(..) ) +import System ( getArgs, exitWith, ExitCode(..) ) import Monad import List -import System import Maybe -import Char + +#ifndef mingw32_TARGET_OS +import Concurrent ( myThreadId ) +#if __GLASGOW_HASKELL__ < 500 +import Exception ( raiseInThread ) +#define throwTo raiseInThread +#else +import Exception ( throwTo ) +#endif + +import Posix ( Handler(Catch), installHandler, sigINT, sigQUIT ) +import Dynamic ( toDyn ) +#endif + + +----------------------------------------------------------------------------- +-- Changes: + +-- * -fglasgow-exts NO LONGER IMPLIES -package lang!!! (-fglasgow-exts is a +-- dynamic flag whereas -package is a static flag.) ----------------------------------------------------------------------------- -- 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: 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 --- -H, -K, -Rghc-timing +-- -K ----------------------------------------------------------------------------- -- Differences vs. old driver: @@ -56,2406 +105,237 @@ import Char -- No more "Enter your Haskell program, end with ^D (on a line of its own):" -- consistency checking removed (may do this properly later) -- removed -noC --- no hi diffs (could be added later) -- no -Ofile ----------------------------------------------------------------------------- --- non-configured things - -cHaskell1Version = "5" -- i.e., Haskell 98 - ------------------------------------------------------------------------------ --- Usage Message - -short_usage = "Usage: For basic information, try the `--help' option." - -long_usage = do - 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 - dump "" = return () - dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s - dump (c:s) = hPutChar stderr c >> dump s - -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_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_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_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 - -{- -Phase of the | Suffix saying | Flag saying | (suffix of) -compilation system | ``start here''| ``stop after''| output file - -literate pre-processor | .lhs | - | - -C pre-processor (opt.) | - | -E | - -Haskell compiler | .hs | -C, -S | .hc, .s -C compiler (opt.) | .hc or .c | -S | .s -assembler | .s or .S | -c | .o -linker | other | - | a.out --} - -data Phase - = MkDependHS -- haskell dependency generation - | Unlit - | Cpp - | Hsc - | Cc - | HCc -- Haskellised C (as opposed to vanilla C) compilation - | Mangle -- assembly mangling, now done by a separate script. - | SplitMangle -- after mangler if splitting - | SplitAs - | As - | Ln - deriving (Eq) - ------------------------------------------------------------------------------ --- Errors - -data BarfKind - = PhaseFailed String ExitCode - | Interrupted - | 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) - -get_prog_name = unsafePerformIO (readIORef prog_name) -- urk! - -instance Show BarfKind where - showsPrec _ e = showString get_prog_name . showString ": " . showBarf e - -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" - -unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f)) - -barfKindTc = mkTyCon "BarfKind" -instance Typeable BarfKind where - typeOf _ = mkAppTy barfKindTc [] - ------------------------------------------------------------------------------ --- Global compilation flags - - - -- Cpp-related flags -hs_source_cpp_opts = global - [ "-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) -GLOBAL_VAR(keep_tmp_files, False, Bool) - - -- Misc -GLOBAL_VAR(scale_sizes_by, 1.0, Double) -GLOBAL_VAR(dry_run, False, Bool) -#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) - ------------------------------------------------------------------------------ --- Splitting object files (for libraries) - -GLOBAL_VAR(split_object_files, False, Bool) -GLOBAL_VAR(split_prefix, "", String) -GLOBAL_VAR(n_split_files, 0, Int) - -can_split :: Bool -can_split = prefixMatch "i386" cTARGETPLATFORM - || prefixMatch "alpha" cTARGETPLATFORM - || prefixMatch "hppa" cTARGETPLATFORM - || prefixMatch "m68k" cTARGETPLATFORM - || prefixMatch "mips" cTARGETPLATFORM - || prefixMatch "powerpc" cTARGETPLATFORM - || prefixMatch "rs6000" cTARGETPLATFORM - || prefixMatch "sparc" cTARGETPLATFORM - ------------------------------------------------------------------------------ --- Compiler output options - -data HscLang - = HscC - | HscAsm - | HscJava - deriving Eq - -GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" && - (prefixMatch "i386" cTARGETPLATFORM || - prefixMatch "sparc" cTARGETPLATFORM) - then HscAsm - else HscC, - HscLang) - -GLOBAL_VAR(output_dir, Nothing, Maybe String) -GLOBAL_VAR(output_suf, Nothing, Maybe String) -GLOBAL_VAR(output_file, Nothing, Maybe String) -GLOBAL_VAR(output_hi, Nothing, Maybe String) - -GLOBAL_VAR(ld_inputs, [], [String]) - -odir_ify :: String -> IO String -odir_ify f = do - odir_opt <- readIORef output_dir - case odir_opt of - Nothing -> return f - Just d -> return (newdir d f) - -osuf_ify :: String -> IO String -osuf_ify f = do - osuf_opt <- readIORef output_suf - case osuf_opt of - Nothing -> return f - Just s -> return (newsuf s f) - ------------------------------------------------------------------------------ --- Hi Files - -GLOBAL_VAR(produceHi, True, Bool) -GLOBAL_VAR(hi_on_stdout, False, Bool) -GLOBAL_VAR(hi_with, "", String) -GLOBAL_VAR(hi_suf, "hi", String) - -data HiDiffFlag = NormalHiDiffs | UsageHiDiffs | NoHiDiffs -GLOBAL_VAR(hi_diffs, NoHiDiffs, HiDiffFlag) - ------------------------------------------------------------------------------ --- Warnings & sanity checking - --- Warning packages that are controlled by -W and -Wall. The 'standard' --- warnings that you get all the time are --- --- -fwarn-overlapping-patterns --- -fwarn-missing-methods --- -fwarn-missing-fields --- -fwarn-deprecations --- -fwarn-duplicate-exports --- --- these are turned off by -Wnot. - -standardWarnings = [ "-fwarn-overlapping-patterns" - , "-fwarn-missing-methods" - , "-fwarn-missing-fields" - , "-fwarn-deprecations" - , "-fwarn-duplicate-exports" - ] -minusWOpts = standardWarnings ++ - [ "-fwarn-unused-binds" - , "-fwarn-unused-matches" - , "-fwarn-incomplete-patterns" - , "-fwarn-unused-imports" - ] -minusWallOpts = minusWOpts ++ - [ "-fwarn-type-defaults" - , "-fwarn-name-shadowing" - , "-fwarn-missing-signatures" - , "-fwarn-hi-shadowing" - ] - -data WarningState = W_default | W_ | W_all | W_not - ------------------------------------------------------------------------------ --- Compiler optimisation options - -GLOBAL_VAR(opt_level, 0, Int) - -setOptLevel :: String -> IO () -setOptLevel "" = do { writeIORef opt_level 1; go_via_C } -setOptLevel "not" = writeIORef opt_level 0 -setOptLevel [c] | isDigit c = do - let level = ord c - ord '0' - writeIORef opt_level level - when (level >= 1) go_via_C -setOptLevel s = unknownFlagErr ("-O"++s) - -go_via_C = do - l <- readIORef hsc_lang - case l of { HscAsm -> writeIORef hsc_lang HscC; - _other -> return () } - -GLOBAL_VAR(opt_minus_o2_for_C, False, Bool) - -GLOBAL_VAR(opt_MaxSimplifierIterations, 4, Int) -GLOBAL_VAR(opt_StgStats, False, Bool) -GLOBAL_VAR(opt_UsageSPInf, False, Bool) -- Off by default - -hsc_minusO2_flags = hsc_minusO_flags -- for now - -hsc_minusNoO_flags = do - iter <- readIORef opt_MaxSimplifierIterations - return [ - "-fignore-interface-pragmas", - "-fomit-interface-pragmas", - "-fsimplify", - "[", - "-fmax-simplifier-iterations" ++ show iter, - "]" - ] - -hsc_minusO_flags = do - iter <- readIORef opt_MaxSimplifierIterations - usageSP <- readIORef opt_UsageSPInf - stgstats <- readIORef opt_StgStats - - return [ - "-ffoldr-build-on", - - "-fdo-eta-reduction", - "-fdo-lambda-eta-expansion", - "-fcase-of-case", - "-fcase-merge", - "-flet-to-case", - - -- initial simplify: mk specialiser happy: minimum effort please - - "-fsimplify", - "[", - "-finline-phase0", - -- Don't inline anything till full laziness has bitten - -- In particular, inlining wrappers inhibits floating - -- e.g. ...(case f x of ...)... - -- ==> ...(case (case x of I# x# -> fw x#) of ...)... - -- ==> ...(case x of I# x# -> case fw x# of ...)... - -- and now the redex (f x) isn't floatable any more - - "-fno-rules", - -- Similarly, don't apply any rules until after full - -- laziness. Notably, list fusion can prevent floating. - - "-fno-case-of-case", - -- Don't do case-of-case transformations. - -- This makes full laziness work better - - "-fmax-simplifier-iterations2", - "]", - - -- Specialisation is best done before full laziness - -- so that overloaded functions have all their dictionary lambdas manifest - "-fspecialise", - - "-ffloat-outwards", - "-ffloat-inwards", - - "-fsimplify", - "[", - "-finline-phase1", - -- Want to run with inline phase 1 after the specialiser to give - -- maximum chance for fusion to work before we inline build/augment - -- in phase 2. This made a difference in 'ansi' where an - -- overloaded function wasn't inlined till too late. - "-fmax-simplifier-iterations" ++ show iter, - "]", - - -- infer usage information here in case we need it later. - -- (add more of these where you need them --KSW 1999-04) - if usageSP then "-fusagesp" else "", - - "-fsimplify", - "[", - -- Need inline-phase2 here so that build/augment get - -- inlined. I found that spectral/hartel/genfft lost some useful - -- strictness in the function sumcode' if augment is not inlined - -- before strictness analysis runs - - "-finline-phase2", - "-fmax-simplifier-iterations2", - "]", - - "-fsimplify", - "[", - "-fmax-simplifier-iterations2", - -- No -finline-phase: allow all Ids to be inlined now - -- This gets foldr inlined before strictness analysis - "]", - - "-fstrictness", - "-fcpr-analyse", - "-fworker-wrapper", - "-fglom-binds", - - "-fsimplify", - "[", - "-fmax-simplifier-iterations" ++ show iter, - -- No -finline-phase: allow all Ids to be inlined now - "]", - - "-ffloat-outwards", - -- nofib/spectral/hartel/wang doubles in speed if you - -- do full laziness late in the day. It only happens - -- after fusion and other stuff, so the early pass doesn't - -- catch it. For the record, the redex is - -- f_el22 (f_el21 r_midblock) - --- Leave out lambda lifting for now --- "-fsimplify", -- Tidy up results of full laziness --- "[", --- "-fmax-simplifier-iterations2", --- "]", --- "-ffloat-outwards-full", - - -- We want CSE to follow the final full-laziness pass, because it may - -- succeed in commoning up things floated out by full laziness. - -- - -- CSE must immediately follow a simplification pass, because it relies - -- on the no-shadowing invariant. See comments at the top of CSE.lhs - -- So it must NOT follow float-inwards, which can give rise to shadowing, - -- even if its input doesn't have shadows. Hence putting it between - -- the two passes. - "-fcse", - - - "-ffloat-inwards", - --- Case-liberation for -O2. This should be after --- strictness analysis and the simplification which follows it. - --- ( ($OptLevel != 2) --- ? "" --- : "-fliberate-case -fsimplify [ $Oopt_FB_Support -ffloat-lets-exposing-whnf -ffloat-primops-ok -fcase-of-case -fdo-case-elim -fcase-merge -fdo-lambda-eta-expansion -freuse-con -flet-to-case $Oopt_PedanticBottoms $Oopt_MaxSimplifierIterations $Oopt_ShowSimplifierProgress ]" ), --- --- "-fliberate-case", - - -- Final clean-up simplification: - "-fsimplify", - "[", - "-fmax-simplifier-iterations" ++ show iter, - -- No -finline-phase: allow all Ids to be inlined now - "]" - - ] - ------------------------------------------------------------------------------ --- Paths & Libraries - -split_marker = ':' -- not configurable (ToDo) - -import_paths, include_paths, library_paths :: IORef [String] -GLOBAL_VAR(import_paths, ["."], [String]) -GLOBAL_VAR(include_paths, ["."], [String]) -GLOBAL_VAR(library_paths, [], [String]) - -GLOBAL_VAR(cmdline_libraries, [], [String]) - -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 -{-# NOINLINE packages #-} - -addPackage :: String -> IO () -addPackage package - = do pkg_details <- readIORef package_details - case lookupPkg package pkg_details of - Nothing -> throwDyn (OtherError ("unknown package name: " ++ package)) - Just details -> do - ps <- readIORef packages - unless (package `elem` ps) $ do - mapM_ addPackage (package_deps details) - ps <- readIORef packages - writeIORef packages (package:ps) - -getPackageImportPath :: IO [String] -getPackageImportPath = do - ps <- readIORef packages - ps' <- getPackageDetails ps - return (nub (concat (map import_dirs ps'))) - -getPackageIncludePath :: IO [String] -getPackageIncludePath = do - ps <- readIORef packages - ps' <- getPackageDetails 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) (concatMap c_includes ps')))) - -getPackageLibraryPath :: IO [String] -getPackageLibraryPath = do - ps <- readIORef packages - ps' <- getPackageDetails ps - return (nub (concat (map library_dirs ps'))) - -getPackageLibraries :: IO [String] -getPackageLibraries = do - ps <- readIORef packages - ps' <- getPackageDetails ps - tag <- readIORef build_tag - let suffix = if null tag then "" else '_':tag - 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 (concatMap extra_ghc_opts ps') - -getPackageExtraCcOpts :: IO [String] -getPackageExtraCcOpts = do - ps <- readIORef packages - ps' <- getPackageDetails ps - return (concatMap extra_cc_opts ps') - -getPackageExtraLdOpts :: IO [String] -getPackageExtraLdOpts = do - ps <- readIORef packages - ps' <- getPackageDetails ps - return (concatMap extra_ld_opts ps') - -getPackageDetails :: [String] -> IO [Package] -getPackageDetails ps = do - pkg_details <- readIORef package_details - return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ] - -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 - --- The central concept of a "way" is that all objects in a given --- program must be compiled in the same "way". Certain options change --- parameters of the virtual machine, eg. profiling adds an extra word --- to the object header, so profiling objects cannot be linked with --- non-profiling objects. - --- After parsing the command-line options, we determine which "way" we --- are building - this might be a combination way, eg. profiling+ticky-ticky. - --- We then find the "build-tag" associated with this way, and this --- becomes the suffix used to find .hi files and libraries used in --- this compilation. - -GLOBAL_VAR(build_tag, "", String) - -data WayName - = WayProf - | WayUnreg - | WayDll - | WayTicky - | WayPar - | WayGran - | WaySMP - | WayDebug - | WayUser_a - | WayUser_b - | WayUser_c - | WayUser_d - | WayUser_e - | WayUser_f - | WayUser_g - | WayUser_h - | WayUser_i - | WayUser_j - | WayUser_k - | WayUser_l - | WayUser_m - | WayUser_n - | WayUser_o - | WayUser_A - | WayUser_B - deriving (Eq,Ord) - -GLOBAL_VAR(ways, [] ,[WayName]) - --- ToDo: allow WayDll with any other allowed combination - -allowed_combinations = - [ [WayProf,WayUnreg], - [WayProf,WaySMP] -- works??? - ] - -findBuildTag :: IO [String] -- new options -findBuildTag = do - way_names <- readIORef ways - case sort way_names of - [] -> do writeIORef build_tag "" - return [] - - [w] -> do let details = lkupWay w - writeIORef build_tag (wayTag details) - return (wayOpts details) - - ws -> if ws `notElem` allowed_combinations - 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 - in do - writeIORef build_tag tag - return (concat flags) - -lkupWay w = - case lookup w way_details of - Nothing -> error "findBuildTag" - Just details -> details - -data Way = Way { - wayTag :: String, - wayName :: String, - wayOpts :: [String] - } - -way_details :: [ (WayName, Way) ] -way_details = - [ (WayProf, Way "p" "Profiling" - [ "-fscc-profiling" - , "-DPROFILING" - , "-optc-DPROFILING" - , "-fvia-C" ]), - - (WayTicky, Way "t" "Ticky-ticky Profiling" - [ "-fticky-ticky" - , "-DTICKY_TICKY" - , "-optc-DTICKY_TICKY" - , "-fvia-C" ]), - - (WayUnreg, Way "u" "Unregisterised" - [ "-optc-DNO_REGS" - , "-optc-DUSE_MINIINTERPRETER" - , "-fno-asm-mangling" - , "-funregisterised" - , "-fvia-C" ]), - - (WayDll, Way "dll" "DLLized" - [ ]), - - (WayPar, Way "mp" "Parallel" - [ "-fparallel" - , "-D__PARALLEL_HASKELL__" - , "-optc-DPAR" - , "-package concurrent" - , "-fvia-C" ]), - - (WayGran, Way "mg" "Gransim" - [ "-fgransim" - , "-D__GRANSIM__" - , "-optc-DGRAN" - , "-package concurrent" - , "-fvia-C" ]), - - (WaySMP, Way "s" "SMP" - [ "-fsmp" - , "-optc-pthread" - , "-optl-pthread" - , "-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"]), - (WayUser_c, Way "c" "User way 'c'" ["$WAY_c_REAL_OPTS"]), - (WayUser_d, Way "d" "User way 'd'" ["$WAY_d_REAL_OPTS"]), - (WayUser_e, Way "e" "User way 'e'" ["$WAY_e_REAL_OPTS"]), - (WayUser_f, Way "f" "User way 'f'" ["$WAY_f_REAL_OPTS"]), - (WayUser_g, Way "g" "User way 'g'" ["$WAY_g_REAL_OPTS"]), - (WayUser_h, Way "h" "User way 'h'" ["$WAY_h_REAL_OPTS"]), - (WayUser_i, Way "i" "User way 'i'" ["$WAY_i_REAL_OPTS"]), - (WayUser_j, Way "j" "User way 'j'" ["$WAY_j_REAL_OPTS"]), - (WayUser_k, Way "k" "User way 'k'" ["$WAY_k_REAL_OPTS"]), - (WayUser_l, Way "l" "User way 'l'" ["$WAY_l_REAL_OPTS"]), - (WayUser_m, Way "m" "User way 'm'" ["$WAY_m_REAL_OPTS"]), - (WayUser_n, Way "n" "User way 'n'" ["$WAY_n_REAL_OPTS"]), - (WayUser_o, Way "o" "User way 'o'" ["$WAY_o_REAL_OPTS"]), - (WayUser_A, Way "A" "User way 'A'" ["$WAY_A_REAL_OPTS"]), - (WayUser_B, Way "B" "User way 'B'" ["$WAY_B_REAL_OPTS"]) - ] - ------------------------------------------------------------------------------ --- Programs for particular phases - -GLOBAL_VAR(pgm_L, findFile "unlit" cGHC_UNLIT, String) -GLOBAL_VAR(pgm_P, cRAWCPP, String) -GLOBAL_VAR(pgm_C, findFile "hsc" cGHC_HSC, String) -GLOBAL_VAR(pgm_c, cGCC, String) -GLOBAL_VAR(pgm_m, findFile "ghc-asm" cGHC_MANGLER, String) -GLOBAL_VAR(pgm_s, findFile "ghc-split" cGHC_SPLIT, String) -GLOBAL_VAR(pgm_a, cGCC, String) -GLOBAL_VAR(pgm_l, cGCC, String) - ------------------------------------------------------------------------------ --- Via-C compilation stuff - --- flags returned are: ( all C compilations --- , registerised HC compilations --- ) - -machdepCCOpts - | prefixMatch "alpha" cTARGETPLATFORM - = return ( ["-static"], [] ) - - | prefixMatch "hppa" cTARGETPLATFORM - -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! - -- (very nice, but too bad the HP /usr/include files don't agree.) - = return ( ["-static", "-D_HPUX_SOURCE"], [] ) - - | prefixMatch "m68k" cTARGETPLATFORM - -- -fno-defer-pop : for the .hc files, we want all the pushing/ - -- popping of args to routines to be explicit; if we let things - -- be deferred 'til after an STGJUMP, imminent death is certain! - -- - -- -fomit-frame-pointer : *don't* - -- It's better to have a6 completely tied up being a frame pointer - -- rather than let GCC pick random things to do with it. - -- (If we want to steal a6, then we would try to do things - -- as on iX86, where we *do* steal the frame pointer [%ebp].) - = return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] ) - - | prefixMatch "i386" cTARGETPLATFORM - -- -fno-defer-pop : basically the same game as for m68k - -- - -- -fomit-frame-pointer : *must* in .hc files; because we're stealing - -- the fp (%ebp) for our register maps. - = do n_regs <- readState stolen_x86_regs - sta <- readIORef static - return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" ], - [ "-fno-defer-pop", "-fomit-frame-pointer", - "-DSTOLEN_X86_REGS="++show n_regs ] - ) - - | prefixMatch "mips" cTARGETPLATFORM - = return ( ["static"], [] ) - - | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM - = return ( ["static"], ["-finhibit-size-directive"] ) - - | otherwise - = return ( [], [] ) - ------------------------------------------------------------------------------ --- Build the Hsc command line - -build_hsc_opts :: IO [String] -build_hsc_opts = do - opt_C_ <- getOpts opt_C -- misc hsc opts - - -- warnings - warn_level <- readState warning_opt - let warn_opts = case warn_level of - W_default -> standardWarnings - W_ -> minusWOpts - W_all -> minusWallOpts - W_not -> [] - - -- optimisation - minus_o <- readIORef opt_level - optimisation_opts <- - case minus_o of - 0 -> hsc_minusNoO_flags - 1 -> hsc_minusO_flags - 2 -> hsc_minusO2_flags - _ -> error "unknown opt level" - -- ToDo: -Ofile - - -- STG passes - ways_ <- readIORef ways - let stg_massage | WayProf `elem` ways_ = "-fmassage-stg-for-profiling" - | otherwise = "" - - stg_stats <- readIORef opt_StgStats - let stg_stats_flag | stg_stats = "-dstg-stats" - | otherwise = "" - - let stg_opts = [ stg_massage, stg_stats_flag, "-flet-no-escape" ] - -- let-no-escape always on for now - - verb <- is_verbose - let hi_vers = "-fhi-version="++cProjectVersionInt - static <- (do s <- readIORef static; if s then return "-static" else return "") - - l <- readIORef hsc_lang - let lang = case l of - HscC -> "-olang=C" - HscAsm -> "-olang=asm" - HscJava -> "-olang=java" - - -- get hi-file suffix - hisuf <- readIORef hi_suf - - -- hi-suffix for packages depends on the build tag. - package_hisuf <- - do tag <- readIORef build_tag - if null tag - then return "hi" - else return (tag ++ "_hi") - - import_dirs <- readIORef import_paths - package_import_dirs <- getPackageImportPath - - let hi_map = "-himap=" ++ - makeHiMap import_dirs hisuf - package_import_dirs package_hisuf - split_marker - - hi_map_sep = "-himap-sep=" ++ [split_marker] - - scale <- readIORef scale_sizes_by - heap <- readState specific_heap_size - stack <- readState specific_stack_size - - -- take into account -fno-* flags by removing the equivalent -f* - -- flag from our list. - anti_flags <- getOpts anti_opt_C - let basic_opts = opt_C_ ++ warn_opts ++ optimisation_opts ++ stg_opts - filtered_opts = filter (`notElem` anti_flags) basic_opts - - return - ( - filtered_opts - -- ToDo: C stub files - ++ [ hi_vers, static, verb, lang, hi_map, hi_map_sep ] - ++ rts_opts - ) - -makeHiMap - (import_dirs :: [String]) - (hi_suffix :: String) - (package_import_dirs :: [String]) - (package_hi_suffix :: String) - (split_marker :: Char) - = foldr (add_dir hi_suffix) - (foldr (add_dir package_hi_suffix) "" package_import_dirs) - import_dirs - where - add_dir hisuf dir str = dir ++ "%." ++ hisuf ++ split_marker : str - - -getOptionsFromSource - :: String -- input file - -> IO [String] -- options, if any -getOptionsFromSource file - = do h <- openFile file ReadMode - 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 -- -} - | Just (opts:_) <- matchRegex optionRegex l - -> return (words opts) - | otherwise -> return [] - -optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}" -- -} - ------------------------------------------------------------------------------ -- Main loop -get_source_files :: [String] -> ([String],[String]) -get_source_files = partition (('-' /=) . head) - main = + -- top-level exception handler: any unrecognised exception is a compiler bug. + handle (\exception -> do + hFlush stdout + case exception of + -- an IO exception probably isn't our fault, so don't panic + IOException _ -> hPutStr stderr (show exception) + _other -> hPutStr stderr (show (Panic (show exception))) + exitWith (ExitFailure 1) + ) $ do + -- all error messages are propagated as exceptions - my_catchDyn (\dyn -> case dyn of - PhaseFailed _phase code -> exitWith code - Interrupted -> exitWith (ExitFailure 1) - _ -> do hPutStrLn stderr (show (dyn :: BarfKind)) - exitWith (ExitFailure 1) - ) $ - - -- make sure we clean up after ourselves - later (do forget_it <- readIORef keep_tmp_files - unless forget_it $ do - verb <- readIORef verbose - cleanTempFiles verb - ) + handleDyn (\dyn -> do + hFlush stdout + case dyn of + PhaseFailed _phase code -> exitWith code + Interrupted -> exitWith (ExitFailure 1) + _ -> do hPutStrLn stderr (show (dyn :: GhcException)) + exitWith (ExitFailure 1) + ) $ do + + -- make sure we clean up after ourselves + later (do forget_it <- readIORef v_Keep_tmp_files + unless forget_it $ do + verb <- dynFlag verbosity + cleanTempFiles verb + ) $ do -- exceptions will be blocked while we clean the temporary files, -- so there shouldn't be any difficulty if we receive further -- signals. - do -- install signal handlers - main_thread <- myThreadId - #ifndef mingw32_TARGET_OS - let sig_handler = Catch (raiseInThread main_thread + main_thread <- myThreadId + let sig_handler = Catch (throwTo main_thread (DynException (toDyn Interrupted))) installHandler sigQUIT sig_handler Nothing installHandler sigINT sig_handler Nothing #endif - doIfSet opt_Verbose - (hPutStr stderr "Glasgow Haskell Compiler, Version " >> - hPutStr stderr compiler_version >> - hPutStr stderr ", for Haskell 98, compiled by GHC version " >> - hPutStr stderr booter_version >> - hPutStr stderr "\n") >> - - pgm <- getProgName - writeIORef prog_name pgm - - argv <- getArgs + argv <- getArgs + let (minusB_args, argv') = partition (prefixMatch "-B") argv + top_dir <- initSysTools minusB_args - -- grab any -B options from the command line first - argv' <- setTopDir argv - - -- read the package configuration - conf_file <- readIORef package_config - contents <- readFile conf_file - writeIORef package_details (read contents) + -- Read the package configuration + conf_file <- getPackageConfigPath + readPackageConf conf_file -- find the phase to stop after (i.e. -E, -C, -c, -S flags) - (flags2, todo, stop_flag) <- getToDo argv' - writeIORef v_todo todo + (flags2, mode, stop_flag) <- getGhcMode argv' + writeIORef v_GhcMode mode -- 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 - more_opts <- findBuildTag - _ <- processArgs driver_opts more_opts [] - - -- get the -v flag - verb <- readIORef verbose - - when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file)) + non_static <- processArgs static_flags flags2 [] + + -- -O and --interactive are not a good combination + -- ditto with any kind of way selection + orig_opt_level <- readIORef v_OptLevel + when (orig_opt_level > 0 && mode == DoInteractive) $ + do putStr "warning: -O conflicts with --interactive; -O turned off.\n" + writeIORef v_OptLevel 0 + orig_ways <- readIORef v_Ways + when (not (null orig_ways) && mode == DoInteractive) $ + do throwDyn (UsageError + "--interactive can't be used with -prof, -ticky, -unreg or -smp.") + + -- Find the build tag, and re-process the build-specific options. + -- Also add in flags for unregisterised compilation, if + -- GhcUnregisterised=YES. + way_opts <- findBuildTag + let unreg_opts | cGhcUnregisterised == "YES" = unregFlags + | otherwise = [] + pkg_extra_opts <- getPackageExtraGhcOpts + extra_non_static <- processArgs static_flags + (unreg_opts ++ way_opts ++ pkg_extra_opts) [] + + -- give the static flags to hsc + static_opts <- buildStaticHscOpts + writeIORef v_Static_hsc_opts static_opts + + -- build the default DynFlags (these may be adjusted on a per + -- module basis by OPTIONS pragmas and settings in the interpreter). + + core_todo <- buildCoreToDo + stg_todo <- buildStgToDo + + -- set the "global" HscLang. The HscLang can be further adjusted on a module + -- by module basis, using only the -fvia-C and -fasm flags. If the global + -- HscLang is not HscC or HscAsm, -fvia-C and -fasm have no effect. + opt_level <- readIORef v_OptLevel + + + let lang = case mode of + StopBefore HCc -> HscC + DoInteractive -> HscInterpreted + _other | opt_level >= 1 -> HscC -- -O implies -fvia-C + | otherwise -> defaultHscLang + + setDynFlags (defaultDynFlags{ coreToDo = core_todo, + stgToDo = stg_todo, + hscLang = lang, + -- leave out hscOutName for now + hscOutName = panic "Main.main:hscOutName not set", + + verbosity = 1 + }) + + -- the rest of the arguments are "dynamic" + srcs <- processArgs dynamic_flags (extra_non_static ++ non_static) [] + + -- save the "initial DynFlags" away + saveDynFlags + + -- complain about any unknown flags + mapM unknownFlagErr [ f | f@('-':_) <- srcs ] + + verb <- dynFlag verbosity + + -- Show the GHCi banner +# ifdef GHCI + when (mode == DoInteractive && verb >= 1) $ + hPutStrLn stdout ghciWelcomeMsg +# endif + + -- Display details of the configuration in verbose mode + when (verb >= 2) + (do hPutStr stderr "Glasgow Haskell Compiler, Version " + hPutStr stderr cProjectVersion + hPutStr stderr ", for Haskell 98, compiled by GHC version " + hPutStrLn stderr cBooterVersion) + + when (verb >= 2) + (hPutStrLn stderr ("Using package config file: " ++ conf_file)) + + pkg_details <- readIORef v_Package_details + showPackages pkg_details + + when (verb >= 3) + (hPutStrLn stderr ("Hsc static flags: " ++ unwords static_opts)) + + -- initialise the finder + pkg_avails <- getPackageInfo + initFinder pkg_avails -- mkdependHS is special - when (todo == DoMkDependHS) beginMkDependHS + when (mode == DoMkDependHS) beginMkDependHS - -- 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 && todo /= DoLink && length srcs > 1 - then throwDyn (UsageError "can't apply -o option to multiple source files") + -- -ohi sanity checking + ohi <- readIORef v_Output_hi + if (isJust ohi && + (mode == DoMake || mode == DoInteractive || srcs `lengthExceeds` 1)) + then throwDyn (UsageError "-ohi can only be used when compiling a single source file") else do - if null srcs then throwDyn (UsageError "no input files") 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) + -- make/interactive require invoking the compilation manager + if (mode == DoMake) then beginMake srcs else do + if (mode == DoInteractive) then beginInteractive srcs else do - ------------------------------------------------------------------------------ --- 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 --- 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 --- driver. - --- It would also deal much more cleanly with compilation phases that --- generate multiple intermediates, (eg. hsc generates .hc, .hi, and --- possibly stub files), where some of the output files need to be --- processed further (eg. the stub files need to be compiled by the C --- compiler). - --- A cool thing to do would then be to execute the data flow graph --- concurrently, automatically taking advantage of extra processors on --- 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. - -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)) + -- -o sanity checking + o_file <- readIORef v_Output_file + if (srcs `lengthExceeds` 1 && isJust o_file && mode /= DoLink && mode /= DoMkDLL) + then throwDyn (UsageError "can't apply -o to multiple source files") 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, 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 - - output_fn <- outputFileName (null phases) keep o_suffix - - 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 (null phases && phase == Cpp) $ - run_something "Dump pre-processed file to stdout" - ("cat " ++ 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 - -------------------------------------------------------------------------------- --- 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 () + if null srcs then throwDyn (UsageError "no input files") else do - 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 _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 _suff input_fn output_fn - = do src_opts <- getOptionsFromSource input_fn - -- 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 <- readState cpp_flag - if do_cpp - then do - cpp <- readIORef pgm_P - hscpp_opts <- getOpts opt_P - hs_src_cpp_opts <- readIORef hs_source_cpp_opts - - cmdline_include_paths <- readIORef include_paths - pkg_include_dirs <- getPackageIncludePath - let include_paths = map (\p -> "-I"++p) (cmdline_include_paths - ++ pkg_include_dirs) - - verb <- is_verbose - run_something "C pre-processor" - (unwords - (["echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}'", ">", output_fn, "&&", - cpp, verb] - ++ include_paths - ++ hs_src_cpp_opts - ++ hscpp_opts - ++ [ "-x", "c", input_fn, ">>", output_fn ] - )) - else do - run_something "Ineffective C pre-processor" - ("echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}' > " - ++ output_fn ++ " && cat " ++ input_fn - ++ " >> " ++ output_fn) - return True + let compileFile src = do + restoreDynFlags + + exists <- doesFileExist src + when (not exists) $ + throwDyn (CmdLineError ("file `" ++ src ++ "' does not exist")) + + -- We compile in two stages, because the file may have an + -- OPTIONS pragma that affects the compilation pipeline (eg. -fvia-C) + let (basename, suffix) = splitFilename src + + -- just preprocess (Haskell source only) + let src_and_suff = (src, getFileSuffix src) + let not_hs_file = not (haskellish_src_file src) + pp <- if not_hs_file || mode == StopBefore Hsc || mode == StopBefore HsPp + then return src_and_suff else do + phases <- genPipeline (StopBefore Hsc) stop_flag + False{-not persistent-} defaultHscLang + src_and_suff + pipeLoop phases src_and_suff False{-no linking-} False{-no -o flag-} + basename suffix + + -- rest of compilation + hsc_lang <- dynFlag hscLang + phases <- genPipeline mode stop_flag True hsc_lang pp + (r,_) <- pipeLoop phases pp (mode==DoLink || mode==DoMkDLL) + True{-use -o flag-} basename suffix + return r ------------------------------------------------------------------------------ --- 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 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 current_dir = getdir basename - - paths <- readIORef include_paths - writeIORef include_paths (current_dir : paths) - - -- 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 "" - - -- tmp files for foreign export stub code - tmp_stub_h <- newTempName "stub_h" - tmp_stub_c <- newTempName "stub_c" - 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_flags - ++ [ - source_unchanged, - "-ofile="++output_fn, - "-F="++tmp_stub_c, - "-FH="++tmp_stub_h - ] - ++ 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... - - -- Deal with stubs - let stub_h = basename ++ "_stub.h" - let stub_c = basename ++ "_stub.c" - - -- copy .h_stub file into current dir if present - 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 - addCmdlineHCInclude tmp_stub_h -- hack - - -- copy the _stub.c file into the current dir - run_something "Copy stub .c file" - (unwords [ - "rm -f", stub_c, "&&", - "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&", - "cat", tmp_stub_c, ">> ", stub_c - ]) - - -- compile the _stub.c file w/ gcc - pipeline <- genPipeline (StopBefore Ln) "" stub_c - run_pipeline pipeline stub_c False{-no linking-} - False{-no -o option-} - (basename++"_stub") "c" - - add ld_inputs (basename++"_stub.o") - ) - return True + o_files <- mapM compileFile srcs ------------------------------------------------------------------------------ --- Cc phase - --- 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 _suff input_fn output_fn - | cc_phase == Cc || cc_phase == HCc - = do cc <- readIORef pgm_c - cc_opts <- (getOpts opt_c) - cmdline_include_dirs <- readIORef include_paths - - let hcc = cc_phase == HCc - - -- add package include paths even if we're just compiling - -- .c files; this is the Value Add(TM) that using - -- ghc instead of gcc gives you :) - pkg_include_dirs <- getPackageIncludePath - let include_paths = map (\p -> "-I"++p) (cmdline_include_dirs - ++ pkg_include_dirs) - - c_includes <- getPackageCIncludes - cmdline_includes <- readState cmdline_hc_includes -- -#include options - - let cc_injects | hcc = unlines (map mk_include - (c_includes ++ reverse cmdline_includes)) - | otherwise = "" - mk_include h_file = - case h_file of - '"':_{-"-} -> "#include "++h_file - '<':_ -> "#include "++h_file - _ -> "#include \""++h_file++"\"" - - cc_help <- newTempName "c" - add files_to_clean cc_help - h <- openFile cc_help WriteMode - hPutStr h cc_injects - hPutStrLn h ("#include \"" ++ input_fn ++ "\"\n") - hClose h - - ccout <- newTempName "ccout" - add files_to_clean ccout - - mangle <- readIORef do_asm_mangling - (md_c_flags, md_regd_c_flags) <- machdepCCOpts - - verb <- is_verbose - - o2 <- readIORef opt_minus_o2_for_C - let opt_flag | o2 = "-O2" - | otherwise = "-O" - - 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 - ++ (if cc_phase == HCc && mangle - then md_regd_c_flags - else []) - ++ [ 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 + when (mode == DoMkDependHS) endMkDependHS + when (mode == DoLink) (doLink o_files) + when (mode == DoMkDLL) (doMkDLL o_files) - -- ToDo: postprocess the output from gcc ------------------------------------------------------------------------------ --- Mangle phase - -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 <- readState stolen_x86_regs - return [ show n_regs ] - else return [] - run_something "Assembly Mangler" - (unwords (mangler : - mangler_opts - ++ [ input_fn, output_fn ] - ++ machdep_opts - )) - return True ------------------------------------------------------------------------------ --- Splitting phase - -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 tmpdir - x <- getProcessID - let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x - writeIORef split_prefix split_s_prefix - add files_to_clean (split_s_prefix ++ "__*") -- d:-) - - -- allocate a tmp file to put the no. of split .s files in (sigh) - n_files <- newTempName "n_files" - add files_to_clean n_files - - run_something "Split Assembly File" - (unwords [ splitter - , input_fn - , split_s_prefix - , n_files ] - ) - - -- save the number of split files for future references - s <- readFile n_files - let n = read s :: Int - writeIORef n_split_files n - return True +beginMake :: [String] -> IO () +beginMake fileish_args + = do let (objs, mods) = partition objish_file fileish_args + mapM (add v_Ld_inputs) objs ------------------------------------------------------------------------------ --- As phase - -run_phase As _basename _suff input_fn output_fn - = do as <- readIORef pgm_a - as_opts <- getOpts opt_a - - cmdline_include_paths <- readIORef include_paths - let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths - run_something "Assembler" - (unwords (as : as_opts - ++ cmdline_include_flags - ++ [ "-c", input_fn, "-o", output_fn ] - )) - return True - -run_phase SplitAs basename _suff _input_fn _output_fn - = do as <- readIORef pgm_a - as_opts <- getOpts opt_a - - split_s_prefix <- readIORef split_prefix - n <- readIORef n_split_files - - odir <- readIORef output_dir - let real_odir = case odir of - Nothing -> basename - Just d -> d - - let assemble_file n = do - let input_s = split_s_prefix ++ "__" ++ show n ++ ".s" - let output_o = newdir real_odir - (basename ++ "__" ++ show n ++ ".o") - real_o <- osuf_ify output_o - run_something "Assembler" - (unwords (as : as_opts - ++ [ "-c", "-o", real_o, input_s ] - )) - - mapM_ assemble_file [1..n] - return True + case mods of + [] -> throwDyn (UsageError "no input files") + mod -> do state <- cmInit Batch + (_, ok, _) <- cmLoadModule state mods + when (not ok) (exitWith (ExitFailure 1)) + return () ------------------------------------------------------------------------------ --- Linking - -do_link :: [String] -> IO () -do_link o_files = do - ln <- readIORef pgm_l - verb <- is_verbose - o_file <- readIORef output_file - let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - - pkg_lib_paths <- getPackageLibraryPath - let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths - - lib_paths <- readIORef library_paths - let lib_path_opts = map ("-L"++) lib_paths - - pkg_libs <- getPackageLibraries - let pkg_lib_opts = map (\lib -> "-l"++lib) pkg_libs - - libs <- readIORef cmdline_libraries - let lib_opts = map ("-l"++) (reverse libs) - -- reverse because they're added in reverse order from the cmd line - - pkg_extra_ld_opts <- getPackageExtraLdOpts - - -- 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 ] - ++ o_files - ++ extra_ld_inputs - ++ lib_path_opts - ++ lib_opts - ++ pkg_lib_path_opts - ++ pkg_lib_opts - ++ pkg_extra_ld_opts - ++ extra_ld_opts - ) - ) ------------------------------------------------------------------------------ --- Running an external program - -run_something phase_name cmd - = do - verb <- readIORef verbose - when verb $ do - putStr phase_name - putStrLn ":" - putStrLn cmd - hFlush stdout - - -- test for -n flag - n <- readIORef dry_run - unless n $ do - - -- and run it! -#ifndef mingw32_TARGET_OS - exit_code <- system cmd `catchAllIO` - (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1))) +beginInteractive :: [String] -> IO () +#ifndef GHCI +beginInteractive = throwDyn (CmdLineError "not built for interactive use") #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 when verb (putStr "\n") - return () +beginInteractive fileish_args + = do minus_ls <- readIORef v_Cmdline_libraries ------------------------------------------------------------------------------ --- Flags - -data OptKind - = NoArg (IO ()) -- flag with no argument - | HasArg (String -> IO ()) -- flag has an argument (maybe prefix) - | SepArg (String -> IO ()) -- flag has a separate argument - | Prefix (String -> IO ()) -- flag is a prefix only - | OptPrefix (String -> IO ()) -- flag may be a prefix - | AnySuffix (String -> IO ()) -- flag is a prefix, pass whole arg to fn - | PassFlag (String -> IO ()) -- flag with no arg, pass flag to fn - --- note that ordering is important in the following list: any flag which --- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override --- flags further down the list with the same prefix. - -driver_opts = - [ ------- help ------------------------------------------------------- - ( "?" , NoArg long_usage) - , ( "-help" , NoArg long_usage) - - - ------- version ---------------------------------------------------- - , ( "-version" , NoArg (do hPutStrLn stdout (cProjectName - ++ ", version " ++ version_str) - exitWith ExitSuccess)) - , ( "-numeric-version", NoArg (do hPutStrLn stdout version_str - exitWith ExitSuccess)) - - ------- verbosity ---------------------------------------------------- - , ( "v" , NoArg (writeIORef verbose True) ) - , ( "n" , NoArg (writeIORef dry_run True) ) - - ------- recompilation checker -------------------------------------- - , ( "recomp" , NoArg (writeIORef recomp True) ) - , ( "no-recomp" , NoArg (writeIORef recomp False) ) - - ------- 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) ) - , ( "smp" , NoArg (addNoDups ways WaySMP) ) - , ( "debug" , NoArg (addNoDups ways WayDebug) ) - -- ToDo: user ways - - ------- Interface files --------------------------------------------- - , ( "hi" , NoArg (writeIORef produceHi True) ) - , ( "nohi" , NoArg (writeIORef produceHi False) ) - , ( "hi-diffs" , NoArg (writeIORef hi_diffs NormalHiDiffs) ) - , ( "no-hi-diffs" , NoArg (writeIORef hi_diffs NoHiDiffs) ) - , ( "hi-diffs-with-usages" , NoArg (writeIORef hi_diffs UsageHiDiffs) ) - , ( "keep-hi-diffs" , NoArg (writeIORef keep_hi_diffs True) ) - --"hi-with-*" -> hiw <- readIORef hi_with (ToDo) - - --------- Profiling -------------------------------------------------- - , ( "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 (updateState (\s -> s{ cpp_flag = True })) ) - , ( "#include" , HasArg (addCmdlineHCInclude) ) - , ( "no-link-chk" , NoArg (return ()) ) -- ignored for backwards compat - - ------- Output Redirection ------------------------------------------ - , ( "odir" , HasArg (writeIORef output_dir . Just) ) - , ( "o" , SepArg (writeIORef output_file . Just) ) - , ( "osuf" , HasArg (writeIORef output_suf . Just) ) - , ( "hisuf" , HasArg (writeIORef hi_suf) ) - , ( "tmpdir" , HasArg (writeIORef tmpdir . (++ "/")) ) - , ( "ohi" , HasArg (\s -> case s of - "-" -> writeIORef hi_on_stdout True - _ -> writeIORef output_hi (Just s)) ) - -- -odump? - - , ( "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 - 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 (addToDirList import_paths) ) - , ( "I" , Prefix (addToDirList include_paths) ) - - ------- Libraries --------------------------------------------------- - , ( "L" , Prefix (addToDirList library_paths) ) - , ( "l" , Prefix (add cmdline_libraries) ) - - ------- Packages ---------------------------------------------------- - , ( "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 -------------------------------------------- - , ( "pgmL" , HasArg (writeIORef pgm_L) ) - , ( "pgmP" , HasArg (writeIORef pgm_P) ) - , ( "pgmC" , HasArg (writeIORef pgm_C) ) - , ( "pgmc" , HasArg (writeIORef pgm_c) ) - , ( "pgmm" , HasArg (writeIORef pgm_m) ) - , ( "pgms" , HasArg (writeIORef pgm_s) ) - , ( "pgma" , HasArg (writeIORef pgm_a) ) - , ( "pgml" , HasArg (writeIORef pgm_l) ) - - , ( "optdep" , HasArg (addOpt_dep) ) - , ( "optL" , HasArg (addOpt_L) ) - , ( "optP" , HasArg (addOpt_P) ) - , ( "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 -> addOpt_P ("-D'"++s++"'") ) ) - , ( "U" , Prefix (\s -> addOpt_P ("-U'"++s++"'") ) ) - - ------ Warning opts ------------------------------------------------- - , ( "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 (newHeapSize . decodeSize) ) - , ( "K" , HasArg (newStackSize . decodeSize) ) - , ( "Rscale-sizes" , HasArg (floatOpt scale_sizes_by) ) - - ------ Debugging ---------------------------------------------------- - , ( "dstg-stats" , NoArg (writeIORef opt_StgStats True) ) - - , ( "dno-" , Prefix (\s -> addAntiOpt_C ("-d"++s)) ) - , ( "d" , AnySuffix (addOpt_C) ) - - ------ Machine dependant (-m) stuff --------------------------- - - , ( "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 addOpt_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) ) - - , ( "fmax-simplifier-iterations", - Prefix (writeIORef opt_MaxSimplifierIterations . read) ) - - , ( "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 (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 -> addAntiOpt_C ("-f"++s)) ) - - -- Pass all remaining "-f" options to hsc - , ( "f", AnySuffix (addOpt_C) ) - ] - ------------------------------------------------------------------------------ --- Process command-line - -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 unknownFlagErr dash_arg - - HasArg fio -> - if rest /= "" - then fio rest >> return args - else case args of - [] -> unknownFlagErr dash_arg - (arg1:args1) -> fio arg1 >> return args1 - - SepArg fio -> - case args of - [] -> unknownFlagErr dash_arg - (arg1:args1) -> fio arg1 >> return args1 - - Prefix fio -> - if rest /= "" - then fio rest >> return args - else unknownFlagErr dash_arg - - OptPrefix fio -> fio rest >> return args - - AnySuffix fio -> fio ('-':arg) >> return args - - PassFlag fio -> - if rest /= "" - then unknownFlagErr dash_arg - else fio ('-':arg) >> return args - -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 - [] -> unknownFlagErr ('-':arg) - (one:_) -> one - -is_prefix (NoArg _) = False -is_prefix (SepArg _) = False -is_prefix (PassFlag _) = False -is_prefix _ = True - ------------------------------------------------------------------------------ --- convert sizes like "3.5M" into integers - -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 == '.' - -floatOpt :: IORef Double -> String -> IO () -floatOpt ref str - = writeIORef ref (read str :: Double) - ------------------------------------------------------------------------------ --- Finding files in the installation - -GLOBAL_VAR(topDir, clibdir, String) - - -- grab the last -B option on the command line, and - -- set topDir to its value. -setTopDir :: [String] -> IO [String] -setTopDir args = do - let (minusbs, others) = partition (prefixMatch "-B") args - (case minusbs of - [] -> writeIORef topDir clibdir - some -> writeIORef topDir (drop 2 (last some))) - return others - -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 <- doesFileExist inplace_file - if b then return inplace_file - else return installed_file - ) - ------------------------------------------------------------------------------ --- Utils - -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 -> ((a,b):bs,cs) - -my_prefix_match :: String -> String -> Maybe String -my_prefix_match [] rest = Just rest -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 (p:ps) (s:ss) | p == s = prefixMatch ps ss - | otherwise = False - -postfixMatch :: String -> String -> Bool -postfixMatch pat str = prefixMatch (reverse pat) (reverse str) - -later = flip finally - -my_catchDyn = flip catchDyn - -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] - _:rest -> chunk : split c rest - where (chunk, rest) = break (==c) s - -add :: IORef [a] -> a -> IO () -add var x = do - xs <- readIORef var - writeIORef var (x:xs) - -addNoDups :: Eq a => IORef [a] -> a -> IO () -addNoDups var x = do - xs <- readIORef var - unless (x `elem` xs) $ writeIORef var (x:xs) - -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) - -take_longest_prefix :: String -> Char -> String -take_longest_prefix s c = reverse pre - where (_suf,pre) = break (==c) (reverse s) - -newsuf :: String -> String -> String -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 + let (objs, mods) = partition objish_file fileish_args + libs = map Left objs ++ map Right minus_ls -#ifdef mingw32_TARGET_OS -foreign import "_getpid" getProcessID :: IO Int + state <- cmInit Interactive + interactiveUI state mods libs #endif