Reorganisation of the source tree

Most of the other users of the fptools build system have migrated to
Cabal, and with the move to darcs we can now flatten the source tree
without losing history, so here goes.

The main change is that the ghc/ subdir is gone, and most of what it
contained is now at the top level.  The build system now makes no
pretense at being multi-project, it is just the GHC build system.

No doubt this will break many things, and there will be a period of
instability while we fix the dependencies.  A straightforward build
should work, but I haven't yet fixed binary/source distributions.
Changes to the Building Guide will follow, too.

1 files changed, 476 insertions, 0 deletions

diff --git a/compiler/main/Main.hs b/compiler/main/Main.hs
new file mode 100644
index 0000000000..ec5a116894
--- /dev/null
+++ b/compiler/main/Main.hs
@@ -0,0 +1,476 @@
+{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
+-----------------------------------------------------------------------------
+--
+-- GHC Driver program
+--
+-- (c) The University of Glasgow 2005
+--
+-----------------------------------------------------------------------------
+
+module Main (main) where
+
+#include "HsVersions.h"
+
+-- The official GHC API
+import qualified GHC
+import GHC		( Session, DynFlags(..), GhcMode(..), HscTarget(..),
+			  LoadHowMuch(..), dopt, DynFlag(..) )
+import CmdLineParser
+
+-- Implementations of the various modes (--show-iface, mkdependHS. etc.)
+import MkIface		( showIface )
+import DriverPipeline	( oneShot, compileFile )
+import DriverMkDepend	( doMkDependHS )
+import SysTools		( getTopDir, getUsageMsgPaths )
+#ifdef GHCI
+import InteractiveUI	( ghciWelcomeMsg, interactiveUI )
+#endif
+
+-- Various other random stuff that we need
+import Config		( cProjectVersion, cBooterVersion, cProjectName )
+import Packages		( dumpPackages, initPackages )
+import DriverPhases	( Phase(..), isSourceFilename, anyHsc,
+			  startPhase, isHaskellSrcFilename )
+import StaticFlags	( staticFlags, v_Ld_inputs, parseStaticFlags )
+import DynFlags         ( defaultDynFlags )
+import BasicTypes	( failed )
+import ErrUtils		( Message, debugTraceMsg, putMsg )
+import FastString	( getFastStringTable, isZEncoded, hasZEncoding )
+import Outputable
+import Util
+import Panic
+
+-- Standard Haskell libraries
+import EXCEPTION	( throwDyn )
+import IO
+import Directory	( doesDirectoryExist )
+import System		( getArgs, exitWith, ExitCode(..) )
+import Monad
+import List
+import Maybe
+
+-----------------------------------------------------------------------------
+-- ToDo:
+
+-- time commands when run with -v
+-- user ways
+-- Win32 support: proper signal handling
+-- reading the package configuration file is too slow
+-- -K<size>
+
+-----------------------------------------------------------------------------
+-- GHC's command-line interface
+
+main =
+  GHC.defaultErrorHandler defaultDynFlags $ do
+  
+  argv0 <- getArgs
+  argv1 <- parseStaticFlags =<< GHC.initFromArgs argv0
+
+  -- 2. Parse the "mode" flags (--make, --interactive etc.)
+  (cli_mode, argv2) <- parseModeFlags argv1
+
+  let mode = case cli_mode of
+		DoInteractive	-> Interactive
+		DoEval _	-> Interactive
+		DoMake		-> BatchCompile
+		DoMkDependHS	-> MkDepend
+		_		-> OneShot
+
+  -- start our GHC session
+  session <- GHC.newSession mode
+
+  dflags0 <- GHC.getSessionDynFlags session
+
+  -- set the default HscTarget.  The HscTarget can be further
+  -- adjusted on a module by module basis, using only the -fvia-C and
+  -- -fasm flags.  If the default HscTarget is not HscC or HscAsm,
+  -- -fvia-C and -fasm have no effect.
+  let lang = case cli_mode of 
+		 DoInteractive  -> HscInterpreted
+		 DoEval _	-> HscInterpreted
+		 _other		-> hscTarget dflags0
+
+  let dflags1 = dflags0{ ghcMode = mode,
+                  	 hscTarget  = lang,
+			 -- leave out hscOutName for now
+	                 hscOutName = panic "Main.main:hscOutName not set",
+		  	 verbosity = case cli_mode of
+				 	 DoEval _ -> 0
+				 	 _other   -> 1
+			}
+
+	-- The rest of the arguments are "dynamic"
+	-- Leftover ones are presumably files
+  (dflags2, fileish_args) <- GHC.parseDynamicFlags dflags1 argv2
+
+	-- make sure we clean up after ourselves
+  GHC.defaultCleanupHandler dflags2 $ do
+
+	-- Display banner
+  showBanner cli_mode dflags2
+
+	-- Read the package config(s), and process the package-related
+	-- command-line flags
+  dflags <- initPackages dflags2
+
+  -- we've finished manipulating the DynFlags, update the session
+  GHC.setSessionDynFlags session dflags
+
+  let
+     -- To simplify the handling of filepaths, we normalise all filepaths right 
+     -- away - e.g., for win32 platforms, backslashes are converted
+     -- into forward slashes.
+    normal_fileish_paths = map normalisePath fileish_args
+    (srcs, objs)         = partition_args normal_fileish_paths [] []
+
+  -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on 
+  --       the command-line.
+  mapM_ (consIORef v_Ld_inputs) (reverse objs)
+
+	---------------- Display configuration -----------
+  when (verbosity dflags >= 4) $
+	dumpPackages dflags
+
+  when (verbosity dflags >= 3) $ do
+	hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
+
+	---------------- Final sanity checking -----------
+  checkOptions cli_mode dflags srcs objs
+
+	---------------- Do the business -----------
+  case cli_mode of
+	ShowUsage       -> showGhcUsage cli_mode
+	PrintLibdir     -> do d <- getTopDir; putStrLn d
+	ShowVersion     -> showVersion
+        ShowNumVersion  -> putStrLn cProjectVersion
+        ShowInterface f -> showIface f
+	DoMake 	        -> doMake session srcs
+	DoMkDependHS    -> doMkDependHS session (map fst srcs)
+	StopBefore p    -> oneShot dflags p srcs
+	DoInteractive   -> interactiveUI session srcs Nothing
+	DoEval expr     -> interactiveUI session srcs (Just expr)
+
+  dumpFinalStats dflags
+  exitWith ExitSuccess
+
+#ifndef GHCI
+interactiveUI _ _ _ = 
+  throwDyn (CmdLineError "not built for interactive use")
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Splitting arguments into source files and object files.  This is where we
+-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
+-- file indicating the phase specified by the -x option in force, if any.
+
+partition_args [] srcs objs = (reverse srcs, reverse objs)
+partition_args ("-x":suff:args) srcs objs
+  | "none" <- suff	= partition_args args srcs objs
+  | StopLn <- phase	= partition_args args srcs (slurp ++ objs)
+  | otherwise		= partition_args rest (these_srcs ++ srcs) objs
+	where phase = startPhase suff
+	      (slurp,rest) = break (== "-x") args 
+	      these_srcs = zip slurp (repeat (Just phase))
+partition_args (arg:args) srcs objs
+  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
+  | otherwise               = partition_args args srcs (arg:objs)
+
+    {-
+      We split out the object files (.o, .dll) and add them
+      to v_Ld_inputs for use by the linker.
+
+      The following things should be considered compilation manager inputs:
+
+       - haskell source files (strings ending in .hs, .lhs or other 
+         haskellish extension),
+
+       - module names (not forgetting hierarchical module names),
+
+       - and finally we consider everything not containing a '.' to be
+         a comp manager input, as shorthand for a .hs or .lhs filename.
+
+      Everything else is considered to be a linker object, and passed
+      straight through to the linker.
+    -}
+looks_like_an_input m =  isSourceFilename m 
+		      || looksLikeModuleName m
+		      || '.' `notElem` m
+
+-- -----------------------------------------------------------------------------
+-- Option sanity checks
+
+checkOptions :: CmdLineMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
+     -- Final sanity checking before kicking off a compilation (pipeline).
+checkOptions cli_mode dflags srcs objs = do
+     -- Complain about any unknown flags
+   let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
+   when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
+
+	-- -prof and --interactive are not a good combination
+   when (notNull (wayNames dflags)  && isInterpretiveMode cli_mode) $
+      do throwDyn (UsageError 
+                   "--interactive can't be used with -prof, -ticky, -unreg or -smp.")
+	-- -ohi sanity check
+   if (isJust (outputHi dflags) && 
+      (isCompManagerMode cli_mode || srcs `lengthExceeds` 1))
+	then throwDyn (UsageError "-ohi can only be used when compiling a single source file")
+	else do
+
+	-- -o sanity checking
+   if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
+	 && not (isLinkMode cli_mode))
+	then throwDyn (UsageError "can't apply -o to multiple source files")
+	else do
+
+	-- Check that there are some input files
+	-- (except in the interactive case)
+   if null srcs && null objs && needsInputsMode cli_mode
+	then throwDyn (UsageError "no input files")
+	else do
+
+     -- Verify that output files point somewhere sensible.
+   verifyOutputFiles dflags
+
+
+-- Compiler output options
+
+-- called to verify that the output files & directories
+-- point somewhere valid. 
+--
+-- The assumption is that the directory portion of these output
+-- options will have to exist by the time 'verifyOutputFiles'
+-- is invoked.
+-- 
+verifyOutputFiles :: DynFlags -> IO ()
+verifyOutputFiles dflags = do
+  let odir = objectDir dflags
+  when (isJust odir) $ do
+     let dir = fromJust odir
+     flg <- doesDirectoryExist dir
+     when (not flg) (nonExistentDir "-odir" dir)
+  let ofile = outputFile dflags
+  when (isJust ofile) $ do
+     let fn = fromJust ofile
+     flg <- doesDirNameExist fn
+     when (not flg) (nonExistentDir "-o" fn)
+  let ohi = outputHi dflags
+  when (isJust ohi) $ do
+     let hi = fromJust ohi
+     flg <- doesDirNameExist hi
+     when (not flg) (nonExistentDir "-ohi" hi)
+ where
+   nonExistentDir flg dir = 
+     throwDyn (CmdLineError ("error: directory portion of " ++ 
+                             show dir ++ " does not exist (used with " ++ 
+			     show flg ++ " option.)"))
+
+-----------------------------------------------------------------------------
+-- GHC modes of operation
+
+data CmdLineMode
+  = ShowUsage			-- ghc -?
+  | PrintLibdir			-- ghc --print-libdir
+  | ShowVersion			-- ghc -V/--version
+  | ShowNumVersion		-- ghc --numeric-version
+  | ShowInterface String	-- ghc --show-iface
+  | DoMkDependHS		-- ghc -M
+  | StopBefore Phase		-- ghc -E | -C | -S
+				-- StopBefore StopLn is the default
+  | DoMake			-- ghc --make
+  | DoInteractive		-- ghc --interactive
+  | DoEval String		-- ghc -e
+  deriving (Show)
+
+isInteractiveMode, isInterpretiveMode     :: CmdLineMode -> Bool
+isLinkMode, isCompManagerMode :: CmdLineMode -> Bool
+
+isInteractiveMode DoInteractive = True
+isInteractiveMode _		= False
+
+-- isInterpretiveMode: byte-code compiler involved
+isInterpretiveMode DoInteractive = True
+isInterpretiveMode (DoEval _)    = True
+isInterpretiveMode _             = False
+
+needsInputsMode DoMkDependHS	= True
+needsInputsMode (StopBefore _)	= True
+needsInputsMode DoMake		= True
+needsInputsMode _		= False
+
+-- True if we are going to attempt to link in this mode.
+-- (we might not actually link, depending on the GhcLink flag)
+isLinkMode (StopBefore StopLn) = True
+isLinkMode DoMake	       = True
+isLinkMode _   		       = False
+
+isCompManagerMode DoMake        = True
+isCompManagerMode DoInteractive = True
+isCompManagerMode (DoEval _)    = True
+isCompManagerMode _             = False
+
+
+-- -----------------------------------------------------------------------------
+-- Parsing the mode flag
+
+parseModeFlags :: [String] -> IO (CmdLineMode, [String])
+parseModeFlags args = do
+  let ((leftover, errs), (mode, _, flags)) = 
+	 runCmdLine (processArgs mode_flags args) (StopBefore StopLn, "", []) 
+  when (not (null errs)) $ do
+    throwDyn (UsageError (unlines errs))
+  return (mode, flags ++ leftover)
+
+type ModeM a = CmdLineP (CmdLineMode, String, [String]) a
+  -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
+  -- so we collect the new ones and return them.
+
+mode_flags :: [(String, OptKind (CmdLineP (CmdLineMode, String, [String])))]
+mode_flags =
+  [  ------- help / version ----------------------------------------------
+     ( "?"    		 , PassFlag (setMode ShowUsage))
+  ,  ( "-help"	 	 , PassFlag (setMode ShowUsage))
+  ,  ( "-print-libdir"   , PassFlag (setMode PrintLibdir))
+  ,  ( "V"	 	 , PassFlag (setMode ShowVersion))
+  ,  ( "-version"	 , PassFlag (setMode ShowVersion))
+  ,  ( "-numeric-version", PassFlag (setMode ShowNumVersion))
+
+      ------- interfaces ----------------------------------------------------
+  ,  ( "-show-iface"     , HasArg (\f -> setMode (ShowInterface f)
+					  "--show-iface"))
+
+      ------- primary modes ------------------------------------------------
+  ,  ( "M"		, PassFlag (setMode DoMkDependHS))
+  ,  ( "E"		, PassFlag (setMode (StopBefore anyHsc)))
+  ,  ( "C"		, PassFlag (\f -> do setMode (StopBefore HCc) f
+					     addFlag "-fvia-C"))
+  ,  ( "S"		, PassFlag (setMode (StopBefore As)))
+  ,  ( "-make"		, PassFlag (setMode DoMake))
+  ,  ( "-interactive"	, PassFlag (setMode DoInteractive))
+  ,  ( "e"              , HasArg   (\s -> setMode (DoEval s) "-e"))
+
+	-- -fno-code says to stop after Hsc but don't generate any code.
+  ,  ( "fno-code"	, PassFlag (\f -> do setMode (StopBefore HCc) f
+					     addFlag "-fno-code"
+					     addFlag "-no-recomp"))
+  ]
+
+setMode :: CmdLineMode -> String -> ModeM ()
+setMode m flag = do
+  (old_mode, old_flag, flags) <- getCmdLineState
+  when (notNull old_flag && flag /= old_flag) $
+      throwDyn (UsageError 
+          ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))
+  putCmdLineState (m, flag, flags)
+
+addFlag :: String -> ModeM ()
+addFlag s = do
+  (m, f, flags) <- getCmdLineState
+  putCmdLineState (m, f, s:flags)
+
+
+-- ----------------------------------------------------------------------------
+-- Run --make mode
+
+doMake :: Session -> [(String,Maybe Phase)] -> IO ()
+doMake sess []    = throwDyn (UsageError "no input files")
+doMake sess srcs  = do 
+    let (hs_srcs, non_hs_srcs) = partition haskellish srcs
+
+	haskellish (f,Nothing) = 
+	  looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
+	haskellish (f,Just phase) = 
+	  phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]
+
+    dflags <- GHC.getSessionDynFlags sess
+    o_files <- mapM (compileFile dflags StopLn) non_hs_srcs
+    mapM_ (consIORef v_Ld_inputs) (reverse o_files)
+
+    targets <- mapM (uncurry GHC.guessTarget) hs_srcs
+    GHC.setTargets sess targets
+    ok_flag <- GHC.load sess LoadAllTargets
+    when (failed ok_flag) (exitWith (ExitFailure 1))
+    return ()
+
+-- ---------------------------------------------------------------------------
+-- Various banners and verbosity output.
+
+showBanner :: CmdLineMode -> DynFlags -> IO ()
+showBanner cli_mode dflags = do
+   let verb = verbosity dflags
+	-- Show the GHCi banner
+#  ifdef GHCI
+   when (isInteractiveMode cli_mode && verb >= 1) $
+      hPutStrLn stdout ghciWelcomeMsg
+#  endif
+
+	-- Display details of the configuration in verbose mode
+   when (not (isInteractiveMode cli_mode) && verb >= 2) $
+	do hPutStr stderr "Glasgow Haskell Compiler, Version "
+ 	   hPutStr stderr cProjectVersion
+	   hPutStr stderr ", for Haskell 98, compiled by GHC version "
+#ifdef GHCI
+	   -- GHCI is only set when we are bootstrapping...
+ 	   hPutStrLn stderr cProjectVersion
+#else
+	   hPutStrLn stderr cBooterVersion
+#endif
+
+showVersion :: IO ()
+showVersion = do
+  putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
+  exitWith ExitSuccess
+
+showGhcUsage cli_mode = do 
+  (ghc_usage_path,ghci_usage_path) <- getUsageMsgPaths
+  let usage_path 
+	| DoInteractive <- cli_mode = ghci_usage_path
+	| otherwise		    = ghc_usage_path
+  usage <- readFile usage_path
+  dump usage
+  exitWith ExitSuccess
+  where
+     dump ""	      = return ()
+     dump ('$':'$':s) = putStr progName >> dump s
+     dump (c:s)	      = putChar c >> dump s
+
+dumpFinalStats :: DynFlags -> IO ()
+dumpFinalStats dflags = 
+  when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
+
+dumpFastStringStats :: DynFlags -> IO ()
+dumpFastStringStats dflags = do
+  buckets <- getFastStringTable
+  let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets
+      msg = text "FastString stats:" $$
+	    nest 4 (vcat [text "size:           " <+> int (length buckets),
+			  text "entries:        " <+> int entries,
+			  text "longest chain:  " <+> int longest,
+			  text "z-encoded:      " <+> (is_z `pcntOf` entries),
+			  text "has z-encoding: " <+> (has_z `pcntOf` entries)
+			 ])
+	-- we usually get more "has z-encoding" than "z-encoded", because
+	-- when we z-encode a string it might hash to the exact same string,
+	-- which will is not counted as "z-encoded".  Only strings whose
+	-- Z-encoding is different from the original string are counted in
+	-- the "z-encoded" total.
+  putMsg dflags msg
+  where
+   x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
+  
+countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z)
+countFS entries longest is_z has_z (b:bs) = 
+  let
+	len = length b
+	longest' = max len longest
+	entries' = entries + len
+	is_zs = length (filter isZEncoded b)
+	has_zs = length (filter hasZEncoding b)
+  in
+	countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs
+
+-- -----------------------------------------------------------------------------
+-- Util
+
+unknownFlagsErr :: [String] -> a
+unknownFlagsErr fs = throwDyn (UsageError ("unrecognised flags: " ++ unwords fs))