1 {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
2 -----------------------------------------------------------------------------
6 -- (c) The University of Glasgow 2005
8 -----------------------------------------------------------------------------
10 module Main (main) where
12 #include "HsVersions.h"
15 import InteractiveUI ( ghciWelcomeMsg, interactiveUI )
19 import MkIface ( showIface )
20 import CompManager ( cmInit, cmLoadModules, cmDepAnal )
23 import Packages ( dumpPackages, initPackages, haskell98PackageId,
25 import DriverPipeline ( runPipeline, staticLink, doMkDLL )
27 import DriverMkDepend ( doMkDependHS )
28 import DriverPhases ( Phase(..), isStopLn, isSourceFilename, anyHsc )
31 import StaticFlags ( parseStaticFlags, staticFlags, v_Ld_inputs )
33 import BasicTypes ( failed )
37 -- Standard Haskell libraries
38 import EXCEPTION ( throwDyn, Exception(..),
39 AsyncException(StackOverflow) )
42 import Directory ( doesFileExist, doesDirectoryExist )
43 import System ( getArgs, exitWith, ExitCode(..) )
48 -----------------------------------------------------------------------------
51 -- time commands when run with -v
53 -- Win32 support: proper signal handling
54 -- reading the package configuration file is too slow
57 -----------------------------------------------------------------------------
61 ---------------------------------------
64 -- top-level exception handler: any unrecognised exception is a compiler bug.
65 handle (\exception -> do
68 -- an IO exception probably isn't our fault, so don't panic
69 IOException _ -> hPutStrLn stderr (show exception)
70 AsyncException StackOverflow ->
71 hPutStrLn stderr "stack overflow: use +RTS -K<size> to increase it"
72 _other -> hPutStr stderr (show (Panic (show exception)))
73 exitWith (ExitFailure 1)
76 -- all error messages are propagated as exceptions
80 PhaseFailed _ code -> exitWith code
81 Interrupted -> exitWith (ExitFailure 1)
82 _ -> do hPutStrLn stderr (show (dyn :: GhcException))
83 exitWith (ExitFailure 1)
88 ----------------------------------------
89 -- command-line parsing
92 -- 1. we grab the -B option if there is one
93 let (minusB_args, argv1) = partition (prefixMatch "-B") argv0
94 dflags0 <- initSysTools minusB_args defaultDynFlags
96 -- 2. Parse the "mode" flags (--make, --interactive etc.)
97 (cli_mode, argv2) <- parseModeFlags argv1
99 -- 3. Parse the static flags
100 argv3 <- parseStaticFlags argv2
102 -- 4. Parse the dynamic flags
103 dflags1 <- initDynFlags dflags0
105 -- set the default HscTarget. The HscTarget can be further
106 -- adjusted on a module by module basis, using only the -fvia-C and
107 -- -fasm flags. If the default HscTarget is not HscC or HscAsm,
108 -- -fvia-C and -fasm have no effect.
109 let lang = case cli_mode of
110 DoInteractive -> HscInterpreted
111 DoEval _ -> HscInterpreted
112 _other -> hscTarget dflags1
114 let mode = case cli_mode of
115 DoInteractive -> Interactive
116 DoEval _ -> Interactive
117 DoMake -> BatchCompile
118 DoMkDependHS -> MkDepend
121 let dflags2 = dflags1{ ghcMode = mode,
123 -- leave out hscOutName for now
124 hscOutName = panic "Main.main:hscOutName not set",
125 verbosity = case cli_mode of
130 -- The rest of the arguments are "dynamic"
131 -- Leftover ones are presumably files
132 (dflags3, fileish_args) <- parseDynamicFlags dflags2 argv3
134 -- make sure we clean up after ourselves
135 later (unless (dopt Opt_KeepTmpFiles dflags3) $
136 cleanTempFiles dflags3) $ do
137 -- exceptions will be blocked while we clean the temporary files,
138 -- so there shouldn't be any difficulty if we receive further
142 showBanner cli_mode dflags3
144 -- Read the package config(s), and process the package-related
145 -- command-line flags
146 dflags <- initPackages dflags3
150 We split out the object files (.o, .dll) and add them
151 to v_Ld_inputs for use by the linker.
153 The following things should be considered compilation manager inputs:
155 - haskell source files (strings ending in .hs, .lhs or other
156 haskellish extension),
158 - module names (not forgetting hierarchical module names),
160 - and finally we consider everything not containing a '.' to be
161 a comp manager input, as shorthand for a .hs or .lhs filename.
163 Everything else is considered to be a linker object, and passed
164 straight through to the linker.
166 looks_like_an_input m = isSourceFilename m
167 || looksLikeModuleName m
170 -- To simplify the handling of filepaths, we normalise all filepaths right
171 -- away - e.g., for win32 platforms, backslashes are converted
172 -- into forward slashes.
173 normal_fileish_paths = map normalisePath fileish_args
174 (srcs, objs) = partition looks_like_an_input normal_fileish_paths
176 -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on
178 mapM_ (consIORef v_Ld_inputs) (reverse objs)
180 ---------------- Display configuration -----------
181 when (verbosity dflags >= 4) $
184 when (verbosity dflags >= 3) $ do
185 hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
187 ---------------- Final sanity checking -----------
188 checkOptions cli_mode dflags srcs objs
190 ---------------- Do the business -----------
192 ShowUsage -> showGhcUsage cli_mode
193 PrintLibdir -> do d <- getTopDir; putStrLn d
194 ShowVersion -> showVersion
195 ShowNumVersion -> putStrLn cProjectVersion
196 ShowInterface f -> showIface f
197 DoMake -> doMake dflags srcs
198 DoMkDependHS -> doMkDependHS dflags srcs
199 StopBefore p -> oneShot dflags p srcs
200 DoInteractive -> interactiveUI dflags srcs Nothing
201 DoEval expr -> interactiveUI dflags srcs (Just expr)
206 interactiveUI _ _ _ =
207 throwDyn (CmdLineError "not built for interactive use")
211 -- -----------------------------------------------------------------------------
212 -- Option sanity checks
214 checkOptions :: CmdLineMode -> DynFlags -> [String] -> [String] -> IO ()
215 -- Final sanity checking before kicking off a compilation (pipeline).
216 checkOptions cli_mode dflags srcs objs = do
217 -- Complain about any unknown flags
218 let unknown_opts = [ f | f@('-':_) <- srcs ]
219 when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
221 -- -prof and --interactive are not a good combination
222 when (notNull (wayNames dflags) && isInterpretiveMode cli_mode) $
223 do throwDyn (UsageError
224 "--interactive can't be used with -prof, -ticky, -unreg or -smp.")
226 if (isJust (outputHi dflags) &&
227 (isCompManagerMode cli_mode || srcs `lengthExceeds` 1))
228 then throwDyn (UsageError "-ohi can only be used when compiling a single source file")
231 -- -o sanity checking
232 if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
233 && not (isLinkMode cli_mode))
234 then throwDyn (UsageError "can't apply -o to multiple source files")
237 -- Check that there are some input files
238 -- (except in the interactive case)
239 if null srcs && null objs && not (isInterpretiveMode cli_mode)
240 then throwDyn (UsageError "no input files")
243 -- Verify that output files point somewhere sensible.
244 verifyOutputFiles dflags
247 -- Compiler output options
249 -- called to verify that the output files & directories
250 -- point somewhere valid.
252 -- The assumption is that the directory portion of these output
253 -- options will have to exist by the time 'verifyOutputFiles'
256 verifyOutputFiles :: DynFlags -> IO ()
257 verifyOutputFiles dflags = do
258 let odir = outputDir dflags
259 when (isJust odir) $ do
260 let dir = fromJust odir
261 flg <- doesDirectoryExist dir
262 when (not flg) (nonExistentDir "-odir" dir)
263 let ofile = outputFile dflags
264 when (isJust ofile) $ do
265 let fn = fromJust ofile
266 flg <- doesDirNameExist fn
267 when (not flg) (nonExistentDir "-o" fn)
268 let ohi = outputHi dflags
269 when (isJust ohi) $ do
270 let hi = fromJust ohi
271 flg <- doesDirNameExist hi
272 when (not flg) (nonExistentDir "-ohi" hi)
274 nonExistentDir flg dir =
275 throwDyn (CmdLineError ("error: directory portion of " ++
276 show dir ++ " does not exist (used with " ++
277 show flg ++ " option.)"))
279 -----------------------------------------------------------------------------
280 -- GHC modes of operation
283 = ShowUsage -- ghc -?
284 | PrintLibdir -- ghc --print-libdir
285 | ShowVersion -- ghc -V/--version
286 | ShowNumVersion -- ghc --numeric-version
287 | ShowInterface String -- ghc --show-iface
288 | DoMkDependHS -- ghc -M
289 | StopBefore Phase -- ghc -E | -C | -S
290 -- StopBefore StopLn is the default
291 | DoMake -- ghc --make
292 | DoInteractive -- ghc --interactive
293 | DoEval String -- ghc -e
296 isInteractiveMode, isInterpretiveMode :: CmdLineMode -> Bool
297 isLinkMode, isCompManagerMode :: CmdLineMode -> Bool
299 isInteractiveMode DoInteractive = True
300 isInteractiveMode _ = False
302 -- isInterpretiveMode: byte-code compiler involved
303 isInterpretiveMode DoInteractive = True
304 isInterpretiveMode (DoEval _) = True
305 isInterpretiveMode _ = False
307 -- True if we are going to attempt to link in this mode.
308 -- (we might not actually link, depending on the GhcLink flag)
309 isLinkMode (StopBefore StopLn) = True
310 isLinkMode DoMake = True
313 isCompManagerMode DoMake = True
314 isCompManagerMode DoInteractive = True
315 isCompManagerMode (DoEval _) = True
316 isCompManagerMode _ = False
319 -- -----------------------------------------------------------------------------
320 -- Parsing the mode flag
322 parseModeFlags :: [String] -> IO (CmdLineMode, [String])
323 parseModeFlags args = do
324 let ((leftover, errs), (mode, _, flags)) =
325 runCmdLine (processArgs mode_flags args) (StopBefore StopLn, "", [])
326 when (not (null errs)) $ do
327 throwDyn (UsageError (unlines errs))
328 return (mode, flags ++ leftover)
330 type ModeM a = CmdLineP (CmdLineMode, String, [String]) a
331 -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
332 -- so we collect the new ones and return them.
334 mode_flags :: [(String, OptKind (CmdLineP (CmdLineMode, String, [String])))]
336 [ ------- help / version ----------------------------------------------
337 ( "?" , PassFlag (setMode ShowUsage))
338 , ( "-help" , PassFlag (setMode ShowUsage))
339 , ( "-print-libdir" , PassFlag (setMode PrintLibdir))
340 , ( "V" , PassFlag (setMode ShowVersion))
341 , ( "-version" , PassFlag (setMode ShowVersion))
342 , ( "-numeric-version", PassFlag (setMode ShowNumVersion))
344 ------- interfaces ----------------------------------------------------
345 , ( "-show-iface" , HasArg (\f -> setMode (ShowInterface f)
348 ------- primary modes ------------------------------------------------
349 , ( "M" , PassFlag (setMode DoMkDependHS))
350 , ( "E" , PassFlag (setMode (StopBefore anyHsc)))
351 , ( "C" , PassFlag (\f -> do setMode (StopBefore HCc) f
353 , ( "S" , PassFlag (setMode (StopBefore As)))
354 , ( "-make" , PassFlag (setMode DoMake))
355 , ( "-interactive" , PassFlag (setMode DoInteractive))
356 , ( "e" , HasArg (\s -> setMode (DoEval s) "-e"))
358 -- -fno-code says to stop after Hsc but don't generate any code.
359 , ( "fno-code" , PassFlag (\f -> do setMode (StopBefore HCc) f
361 addFlag "-no-recomp"))
364 setMode :: CmdLineMode -> String -> ModeM ()
366 (old_mode, old_flag, flags) <- getCmdLineState
367 when (notNull old_flag && flag /= old_flag) $
369 ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))
370 putCmdLineState (m, flag, flags)
372 addFlag :: String -> ModeM ()
374 (m, f, flags) <- getCmdLineState
375 putCmdLineState (m, f, s:flags)
378 -- -----------------------------------------------------------------------------
379 -- Compile files in one-shot mode.
381 oneShot :: DynFlags -> Phase -> [String] -> IO ()
382 oneShot dflags stop_phase srcs = do
383 o_files <- compileFiles stop_phase dflags srcs
384 doLink dflags stop_phase o_files
386 compileFiles :: Phase
388 -> [String] -- Source files
389 -> IO [String] -- Object files
390 compileFiles stop_phase dflags srcs
391 = mapM (compileFile stop_phase dflags) srcs
393 compileFile :: Phase -> DynFlags -> FilePath -> IO FilePath
394 compileFile stop_phase dflags src = do
395 exists <- doesFileExist src
397 throwDyn (CmdLineError ("does not exist: " ++ src))
400 split = dopt Opt_SplitObjs dflags
401 o_file = outputFile dflags
402 ghc_link = ghcLink dflags -- Set by -c or -no-link
404 -- When linking, the -o argument refers to the linker's output.
405 -- otherwise, we use it as the name for the pipeline's output.
407 | StopLn <- stop_phase, not (isNoLink ghc_link) = Nothing
408 -- -o foo applies to linker
410 -- -o foo applies to the file we are compiling now
412 stop_phase' = case stop_phase of
413 As | split -> SplitAs
416 (_, out_file) <- runPipeline stop_phase' dflags
417 True maybe_o_file src Nothing{-no ModLocation-}
421 doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
422 doLink dflags stop_phase o_files
423 | not (isStopLn stop_phase)
424 = return () -- We stopped before the linking phase
427 = case ghcLink dflags of
429 StaticLink -> staticLink dflags o_files link_pkgs
430 MkDLL -> doMkDLL dflags o_files link_pkgs
432 -- Always link in the haskell98 package for static linking. Other
433 -- packages have to be specified via the -package flag.
435 | ExtPackage h98_id <- haskell98PackageId (pkgState dflags) = [h98_id]
439 -- ----------------------------------------------------------------------------
442 doMake :: DynFlags -> [String] -> IO ()
443 doMake dflags [] = throwDyn (UsageError "no input files")
444 doMake dflags srcs = do
445 state <- cmInit dflags
446 graph <- cmDepAnal state srcs
447 (_, ok_flag, _) <- cmLoadModules state graph
448 when (failed ok_flag) (exitWith (ExitFailure 1))
452 -- ---------------------------------------------------------------------------
453 -- Various banners and verbosity output.
455 showBanner :: CmdLineMode -> DynFlags -> IO ()
456 showBanner cli_mode dflags = do
457 let verb = verbosity dflags
458 -- Show the GHCi banner
460 when (isInteractiveMode cli_mode && verb >= 1) $
461 hPutStrLn stdout ghciWelcomeMsg
464 -- Display details of the configuration in verbose mode
465 when (not (isInteractiveMode cli_mode) && verb >= 2) $
466 do hPutStr stderr "Glasgow Haskell Compiler, Version "
467 hPutStr stderr cProjectVersion
468 hPutStr stderr ", for Haskell 98, compiled by GHC version "
469 hPutStrLn stderr cBooterVersion
473 putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
476 showGhcUsage cli_mode = do
477 (ghc_usage_path,ghci_usage_path) <- getUsageMsgPaths
479 | DoInteractive <- cli_mode = ghci_usage_path
480 | otherwise = ghc_usage_path
481 usage <- readFile usage_path
486 dump ('$':'$':s) = hPutStr stderr progName >> dump s
487 dump (c:s) = hPutChar stderr c >> dump s
489 -- -----------------------------------------------------------------------------
492 unknownFlagsErr :: [String] -> a
493 unknownFlagsErr fs = throwDyn (UsageError ("unrecognised flags: " ++ unwords fs))