+{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
+-- $Id: Main.hs,v 1.69 2000/11/07 10:42:55 simonmar Exp $
+--
-- GHC Driver program
--
-- (c) Simon Marlow 2000
module Main (main) where
+import Utils
+
+import GetImports
import Package
import Config
import IO
import Monad
-import Array
import List
import System
import Maybe
-----------------------------------------------------------------------------
-- 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
-----------------------------------------------------------------------------
-- 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"
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 "")
- -- umm, isn't the patchlevel included in the version number? --SDM
+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
-- 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)
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 []
if '*' `elem` f then system ("rm -f " ++ f) >> return ()
else removeFile f)
`catchAllIO`
- (\e -> when 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)
-
-endPhaseFlag :: String -> Maybe Phase
-endPhaseFlag "-M" = Just MkDependHS
-endPhaseFlag "-E" = Just Cpp
-endPhaseFlag "-C" = Just Hsc
-endPhaseFlag "-S" = Just Mangle
-endPhaseFlag "-c" = Just As
-endPhaseFlag _ = Nothing
-
-getStopAfter :: [String]
- -> IO ( [String] -- rest of command line
- , Phase -- stop after phase
- , String -- "stop after" flag
- , Bool -- do linking?
- )
-getStopAfter flags
- = case my_partition endPhaseFlag flags of
- ([] , rest) -> return (rest, As, "", True)
- ([(flag,one)], rest) -> return (rest, one, flag, 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
, "-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
#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)
= HscC
| HscAsm
| HscJava
+ deriving Eq
GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" &&
(prefixMatch "i386" cTARGETPLATFORM ||
[ "-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
let level = ord c - ord '0'
writeIORef opt_level level
when (level >= 1) go_via_C
-setOptLevel s = throwDyn (UnknownFlag ("-O"++s))
+setOptLevel s = unknownFlagErr ("-O"++s)
go_via_C = do
l <- readIORef hsc_lang
"-fmax-simplifier-iterations2",
"]",
-
"-fsimplify",
"[",
"-fmax-simplifier-iterations2",
"-fstrictness",
"-fcpr-analyse",
"-fworker-wrapper",
+ "-fglom-binds",
"-fsimplify",
"[",
-----------------------------------------------------------------------------
-- Paths & Libraries
-split_marker = ':' -- not configurable
+split_marker = ':' -- not configurable (ToDo)
import_paths, include_paths, library_paths :: IORef [String]
GLOBAL_VAR(import_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
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
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 ()
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
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
getPackageIncludePath :: IO [String]
getPackageIncludePath = do
- ps <- readIORef packages
+ ps <- readIORef packages
ps' <- getPackageDetails ps
return (nub (filter (not.null) (concatMap include_dirs ps')))
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
data WayName
= WayProf
| WayUnreg
- | WayDll
| WayTicky
| WayPar
| WayGran
GLOBAL_VAR(ways, [] ,[WayName])
--- ToDo: allow WayDll with any other allowed combination
-
-allowed_combinations =
- [ [WayProf,WayUnreg],
- [WayProf,WaySMP] -- works???
- ]
+allowed_combination ways = ways `elem` combs
+ where -- the sub-lists must be ordered according to WayName, because findBuildTag sorts them
+ combs = [ [WayProf,WayUnreg], [WayProf,WaySMP] ]
findBuildTag :: IO [String] -- new options
findBuildTag = do
writeIORef build_tag (wayTag details)
return (wayOpts details)
- ws -> if ws `notElem` allowed_combinations
- then throwDyn (WayCombinationNotSupported ws)
+ ws -> if allowed_combination 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
, "-funregisterised"
, "-fvia-C" ]),
- (WayDll, Way "dll" "DLLized"
- [ ]),
-
(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"
-----------------------------------------------------------------------------
-- 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)
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
--
-- -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 "" ],
+ return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "",
+ if suffixMatch "mingw32" cTARGETPLATFORM then "-mno-cygwin" else "" ],
[ "-fno-defer-pop", "-fomit-frame-pointer",
- "-DSTOLEN_X86_REGS="++show n_regs ]
+ "-DSTOLEN_X86_REGS="++show n_regs]
)
| prefixMatch "mips" cTARGETPLATFORM
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
0 -> hsc_minusNoO_flags
1 -> hsc_minusO_flags
2 -> hsc_minusO2_flags
+ _ -> error "unknown opt level"
-- ToDo: -Ofile
-- STG passes
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
-> 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
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,
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, stop_flag, 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 phases to run
- pipelines <- mapM (genPipeline stop_phase stop_flag) 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 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 srcs then throwDyn NoInputFiles else do
+ if null srcs then throwDyn (UsageError "no input files") else do
- let compileFile (src, phases) =
- run_pipeline phases src do_linking True orig_base
- where (orig_base, _) = splitFilename src
+ -- 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 do_linking (do_link o_files)
+ when (todo == DoMkDependHS) endMkDependHS
+
+ when (todo == DoLink) (do_link o_files)
+
+
+-----------------------------------------------------------------------------
+-- Which phase to stop at
+
+data ToDo = DoMkDependHS | 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
-- 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
-- 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
startPhase "s" = As
startPhase "S" = As
startPhase "o" = Ln
+startPhase _ = Ln -- all unknown file types
genPipeline
- :: Phase -- stop after this phase
+ :: ToDo -- when to stop
-> String -- "stop after" flag (for error messages)
-> String -- original filename
-> IO [ -- list of phases to run for this file
String) -- output file suffix
]
-genPipeline stop_after stop_after_flag filename
+genPipeline todo stop_flag filename
= do
split <- readIORef split_object_files
mangle <- readIORef do_asm_mangling
let
----------- ----- ---- --- -- -- - - -
- start_phase = startPhase suffix
+ (_basename, suffix) = splitFilename filename
- (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.??
- -- hack for .hc files
- real_lang | suffix == "hc" = HscC
- | otherwise = lang
+ -- 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,
| split -> not_valid
| otherwise -> [ Unlit, Cpp, Hsc, HCc, As ]
- HscAsm | split -> not_valid
+ HscAsm | split -> [ Unlit, Cpp, Hsc, SplitMangle, SplitAs ]
| otherwise -> [ Unlit, Cpp, Hsc, As ]
HscJava | split -> not_valid
++ filename))
else do
- -- this might happen, eg. ghc -S Foo.o
- if stop_after /= As && stop_after `notElem` pipeline
- then throwDyn (OtherError ("flag " ++ stop_after_flag
- ++ " is incompatible with source file "
- ++ 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] -> Phase
+ :: [Phase] -- raw pipeline
+ -> Phase -- phase to stop before
-> [(Phase, IntermediateFileType, String{-file extension-})]
annotatePipeline [] _ = []
annotatePipeline (Ln:_) _ = []
: annotatePipeline (next_phase:ps) stop
where
keep_this_output
- | phase == stop = Persistent
+ | next_phase == stop = Persistent
| otherwise =
case next_phase of
Ln -> Persistent
-- 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.
- annotated_pipeline = annotatePipeline (pipeline ++ [ Ln ]) stop_after
+ 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_after p then p:ps else [p]) []
+ foldr (\p ps -> if phase_ne stop_phase p then p:ps else []) []
$ annotated_pipeline
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
-> 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 [] input_fn _ _ _ _ = return input_fn
run_pipeline ((phase, keep, o_suffix):phases)
- input_fn do_linking use_ofile orig_basename
+ input_fn do_linking use_ofile orig_basename orig_suffix
= do
- output_fn <-
- (if null phases && 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 ++ '.':o_suffix)
- osuf_ify f
-
- else if keep == Persistent
- then odir_ify (orig_basename ++ '.':o_suffix)
- else do filename <- newTempName o_suffix
- 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 <file>.cpp, so we also have to cat the file here.
run_something "Dump pre-processed file to stdout"
("cat " ++ output_fn)
- run_pipeline phases output_fn do_linking use_ofile orig_basename
+ 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
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
++ [ "-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
-- 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"
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)
+ o_file <- osuf_ify o_file'
+ 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...
+
-- Generate -Rghc-timing info
when (timing) (
run_something "Generate timing stats"
("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"
(unwords [
"rm -f", stub_c, "&&",
- "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
+ "echo \'#include \"Stg.h\"\n#include \""++stub_h++"\"\' >"++stub_c, " &&",
"cat", tmp_stub_c, ">> ", stub_c
])
-- compile the _stub.c file w/ gcc
- pipeline <- genPipeline As "" stub_c
+ pipeline <- genPipeline (StopBefore Ln) "" stub_c
run_pipeline pipeline stub_c False{-no linking-}
False{-no -o option-}
- (basename++"_stub")
+ (basename++"_stub") "c"
add ld_inputs (basename++"_stub.o")
)
+ return True
-----------------------------------------------------------------------------
-- 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 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)
++ 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))
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 ]
++ [ verb, "-S", "-Wimplicit", opt_flag ]
++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
++ cc_opts
-#ifdef mingw32_TARGET_OS
- ++ [" -mno-cygwin"]
-#endif
++ (if excessPrecision then [] else [ "-ffloat-store" ])
++ include_paths
++ pkg_extra_cc_opts
-- ++ [">", ccout]
))
+ return True
-- ToDo: postprocess the output from gcc
-----------------------------------------------------------------------------
-- Mangle phase
-run_phase Mangle basename input_fn output_fn
+run_phase Mangle _basename _suff input_fn output_fn
= do mangler <- readIORef pgm_m
mangler_opts <- getOpts opt_m
machdep_opts <-
if (prefixMatch "i386" cTARGETPLATFORM)
- then do n_regs <- readIORef stolen_x86_regs
+ then do n_regs <- readState stolen_x86_regs
return [ show n_regs ]
else return []
run_something "Assembly Mangler"
++ [ 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
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
++ 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
))
mapM_ assemble_file [1..n]
+ return True
-----------------------------------------------------------------------------
-- Linking
+GLOBAL_VAR(no_hs_main, False, Bool)
+
do_link :: [String] -> IO ()
do_link o_files = do
ln <- readIORef pgm_l
verb <- is_verbose
+ static <- readIORef static
+ let imp = if static then "" else "_imp"
+ no_hs_main <- readIORef no_hs_main
o_file <- readIORef output_file
let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
let lib_path_opts = map ("-L"++) lib_paths
pkg_libs <- getPackageLibraries
- let pkg_lib_opts = map (\lib -> "-l"++lib) pkg_libs
+ let pkg_lib_opts = map (\lib -> "-l" ++ lib ++ imp) pkg_libs
libs <- readIORef cmdline_libraries
let lib_opts = map ("-l"++) (reverse libs)
-- opts from -optl-<blah>
extra_ld_opts <- getOpts opt_l
+ rts_pkg <- getPackageDetails ["rts"]
+ std_pkg <- getPackageDetails ["std"]
+#ifdef mingw32_TARGET_OS
+ let extra_os = if static || no_hs_main
+ then []
+ else [ head (library_dirs (head rts_pkg)) ++ "/Main.dll_o",
+ head (library_dirs (head std_pkg)) ++ "/PrelMain.dll_o" ]
+#endif
+ (md_c_flags, _) <- machdepCCOpts
run_something "Linker"
- (unwords
+ (unwords
([ ln, verb, "-o", output_fn ]
+ ++ md_c_flags
++ o_files
+#ifdef mingw32_TARGET_OS
+ ++ extra_os
+#endif
++ extra_ld_inputs
++ lib_path_opts
++ lib_opts
++ pkg_lib_opts
++ pkg_extra_ld_opts
++ extra_ld_opts
+#ifdef mingw32_TARGET_OS
+ ++ if static then [ "-u _PrelMain_mainIO_closure" , "-u ___init_PrelMain"] else []
+#else
+ ++ [ "-u PrelMain_mainIO_closure" , "-u __init_PrelMain"]
+#endif
)
)
-- 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
hPutStrLn h cmd
hClose h
exit_code <- system ("sh - " ++ tmp) `catchAllIO`
- (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
+ (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
removeFile tmp
#endif
-- 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)
------- 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) )
--"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
+ , ( "no-hs-main" , NoArg (writeIORef no_hs_main True) )
------- 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 tmp_prefix . (++ "/")) )
+ , ( "tmpdir" , HasArg (writeIORef tmpdir . (++ "/")) )
, ( "ohi" , HasArg (\s -> case s of
"-" -> writeIORef hi_on_stdout True
_ -> writeIORef output_hi (Just s)) )
, ( "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
, ( "-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) )
, ( "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) )
+ , ( "rdynamic" , NoArg (return ()) ) -- ignored for compat w/ gcc
------ 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<blah>) 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) )
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-<blah>" options cancel out "-f<blah>" on the hsc cmdline
- , ( "fno-", Prefix (\s -> add anti_opt_C ("-f"++s)) )
+ , ( "fno-", Prefix (\s -> addAntiOpt_C ("-f"++s)) )
-- Pass all remaining "-f<blah>" 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
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
-----------------------------------------------------------------------------
-- 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)
-- Utils
my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
-my_partition p [] = ([],[])
+my_partition _ [] = ([],[])
my_partition p (a:as)
= let (bs,cs) = my_partition p as in
case p a of
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 (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_catch = flip catchAllIO
my_catchDyn = flip catchDyn
global :: a -> IORef a
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]
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
remove_spaces :: String -> String
remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
+
+-----------------------------------------------------------------------------
+-- compatibility code
+
+#if __GLASGOW_HASKELL__ <= 408
+catchJust = catchIO
+ioErrors = justIoErrors
+#endif
projects / ghc-hetmet.git / blobdiff