X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fdriver%2FMain.hs;h=03fececccee8cb69b313737b0b63ee864322c302;hb=960c27ce0bd19b643d597737f1ceaa71cd5fea2b;hp=415f0a62c96b5e1924e51fd3cd19e66002b23ca1;hpb=798f758b7034ad004a43c9012ba33b98bed2e309;p=ghc-hetmet.git diff --git a/ghc/driver/Main.hs b/ghc/driver/Main.hs index 415f0a6..03fecec 100644 --- a/ghc/driver/Main.hs +++ b/ghc/driver/Main.hs @@ -18,6 +18,7 @@ import Exception import Dynamic import IO +import Monad import Array import List import System @@ -38,6 +39,7 @@ name = global (value) :: IORef (ty); \ -- user ways -- Win32 support -- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too +-- reading the package configuration file is too slow ----------------------------------------------------------------------------- -- Differences vs. old driver: @@ -51,7 +53,7 @@ name = global (value) :: IORef (ty); \ ----------------------------------------------------------------------------- -- non-configured things -_Haskell1Version = "5" -- i.e., Haskell 98 +cHaskell1Version = "5" -- i.e., Haskell 98 ----------------------------------------------------------------------------- -- Usage Message @@ -120,6 +122,7 @@ data BarfKind | PhaseFailed String ExitCode | Interrupted | NoInputFiles + | OtherError String deriving Eq GLOBAL_VAR(prog_name, "ghc", String) @@ -146,6 +149,8 @@ showBarf (WayCombinationNotSupported ws) (map (showString . wayName . lkupWay) ws) showBarf (NoInputFiles) = showString "no input files" +showBarf (OtherError str) + = showString str barfKindTc = mkTyCon "BarfKind" @@ -201,7 +206,7 @@ getStopAfter flags -- Cpp-related flags GLOBAL_VAR(cpp_flag, False, Bool) hs_source_cpp_opts = global - [ "-D__HASKELL1__="++_Haskell1Version + [ "-D__HASKELL1__="++cHaskell1Version , "-D__GLASGOW_HASKELL__="++cProjectVersionInt , "-D__HASKELL98__" , "-D__CONCURRENT_HASKELL__" @@ -533,6 +538,85 @@ augment_library_paths path ----------------------------------------------------------------------------- -- Packages +GLOBAL_VAR(package_config, (findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")), String) + +listPackages :: IO () +listPackages = do + details <- readIORef package_details + hPutStr stdout (listPkgs details) + hPutChar stdout '\n' + exitWith ExitSuccess + +newPackage :: IO () +newPackage = do + checkConfigAccess + details <- readIORef package_details + hPutStr stdout "Reading package info from stdin... " + stuff <- getContents + let new_pkg = read stuff :: (String,Package) + catchAll new_pkg + (\e -> 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 ++ + "' already installed")) + else do + conf_file <- readIORef package_config + savePackageConfig conf_file + maybeRestoreOldConfig conf_file $ do + writeNewConfig conf_file ( ++ [new_pkg]) + exitWith ExitSuccess + +deletePackage :: String -> IO () +deletePackage pkg = do + checkConfigAccess + details <- readIORef package_details + if (pkg `notElem` map fst 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)) + exitWith ExitSuccess + +checkConfigAccess :: IO () +checkConfigAccess = do + conf_file <- readIORef package_config + access <- fileAccess conf_file True True False + if not access + then throwDyn (OtherError "you don't have permission to modify the package configuration file") + else return () + +maybeRestoreOldConfig :: String -> IO () -> IO () +maybeRestoreOldConfig conf_file io + = catchAllIO io (\e -> do + hPutStr stdout "\nWARNING: an error was encountered while the new \n\ + \configuration was being written. Attempting to \n\ + \restore the old configuration... " + system ("cp " ++ conf_file ++ ".old " ++ conf_file) + hPutStrLn stdout "done." + throw e + ) + +writeNewConfig :: String -> ([(String,Package)] -> [(String,Package)]) -> IO () +writeNewConfig conf_file fn = do + hPutStr stdout "Writing new package config file... " + old_details <- readIORef package_details + h <- openFile conf_file WriteMode + hPutStr h (dumpPackages (fn old_details)) + hClose h + hPutStrLn stdout "done." + +savePackageConfig :: String -> IO () +savePackageConfig conf_file = do + hPutStr stdout "Saving old package config file... " + -- mv rather than cp because we've already done an hGetContents + -- on this file so we won't be able to open it for writing + -- unless we move the old one out of the way... + system ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old") + hPutStrLn stdout "done." + -- package list is maintained in dependency order packages = global ["std", "rts", "gmp"] :: IORef [String] -- comma in value, so can't use macro, grrr @@ -561,14 +645,14 @@ getPackageIncludePath :: IO [String] getPackageIncludePath = do ps <- readIORef packages ps' <- getPackageDetails ps - return (nub (filter (not.null) (map include_dir ps'))) + return (nub (filter (not.null) (concatMap include_dirs ps'))) -- includes are in reverse dependency order (i.e. rts first) getPackageCIncludes :: IO [String] getPackageCIncludes = do ps <- readIORef packages ps' <- getPackageDetails ps - return (reverse (nub (filter (not.null) (map c_include ps')))) + return (reverse (nub (filter (not.null) (concatMap c_includes ps')))) getPackageLibraryPath :: IO [String] getPackageLibraryPath = do @@ -588,26 +672,24 @@ getPackageExtraGhcOpts :: IO [String] getPackageExtraGhcOpts = do ps <- readIORef packages ps' <- getPackageDetails ps - return (map extra_ghc_opts ps') + return (concatMap extra_ghc_opts ps') getPackageExtraCcOpts :: IO [String] getPackageExtraCcOpts = do ps <- readIORef packages ps' <- getPackageDetails ps - return (map extra_cc_opts ps') + return (concatMap extra_cc_opts ps') getPackageExtraLdOpts :: IO [String] getPackageExtraLdOpts = do ps <- readIORef packages ps' <- getPackageDetails ps - return (map extra_ld_opts ps') + return (concatMap extra_ld_opts ps') +getPackageDetails :: [String] -> IO [Package] getPackageDetails ps = do pkg_details <- readIORef package_details - let getDetails p = case lookup p pkg_details of - Just details -> return details - Nothing -> error "getPackageDetails" - mapM getDetails ps + return [ pkg | p <- ps, Just pkg <- [ lookup p pkg_details ] ] GLOBAL_VAR(package_details, (error "package_details"), [(String,Package)]) @@ -1025,8 +1107,8 @@ main = argv' <- setTopDir argv -- read the package configuration - let conf = findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace") - contents <- readFile conf + 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) @@ -1039,6 +1121,11 @@ main = more_opts <- findBuildTag _ <- processArgs more_opts [] + -- 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 @@ -1123,7 +1210,8 @@ run_pipeline last_phase do_linking use_ofile orig_basename (phase, input_fn) case phase of Hsc -> case lang of HscC -> HCc - HscAsm -> As + HscAsm | split -> SplitMangle + | otherwise -> As HCc | mangle -> Mangle | otherwise -> As @@ -1152,11 +1240,11 @@ run_pipeline last_phase do_linking use_ofile orig_basename (phase, input_fn) Ln -> True Mangle | keep_raw_s -> True -- first enhancement :) As | keep_s -> True - Cc | keep_hc -> True + HCc | keep_hc -> True _other -> False output_fn <- - (if phase == last_phase && not do_linking && use_ofile + (if next_phase > last_phase && not do_linking && use_ofile then do o_file <- readIORef output_file case o_file of Just s -> return s @@ -1202,11 +1290,9 @@ newTempName extn = do do_mkdependHS :: [String] -> [String] -> IO () do_mkdependHS cmd_opts srcs = do - - -- # They're not (currently) needed, but we need to quote any -#include options - -- foreach (@Cmd_opts) { - -- s/-#include.*$/'$&'/g; - -- }; + -- HACK + let quote_include_opt o | prefixMatch "-#include" o = "'" ++ o ++ "'" + | otherwise = o mkdependHS <- readIORef pgm_dep mkdependHS_opts <- getOpts opt_dep @@ -1216,7 +1302,7 @@ do_mkdependHS cmd_opts srcs = do (unwords (mkdependHS : mkdependHS_opts ++ hs_src_cpp_opts - ++ ("--" : cmd_opts ) + ++ ("--" : map quote_include_opt cmd_opts ) ++ ("--" : srcs) )) @@ -1679,7 +1765,6 @@ opts = , ( "split-objs" , NoArg (if can_split then do writeIORef split_object_files True - writeIORef hsc_lang HscC add opt_C "-fglobalise-toplev-names" add opt_c "-DUSE_SPLIT_MARKERS" else hPutStrLn stderr @@ -1701,6 +1786,10 @@ opts = , ( "package" , HasArg (addPackage) ) , ( "syslib" , HasArg (addPackage) ) -- for compatibility w/ old vsns + , ( "-list-packages" , NoArg (listPackages) ) + , ( "-add-package" , NoArg (newPackage) ) + , ( "-delete-package" , SepArg (deletePackage) ) + ------- Specific phases -------------------------------------------- , ( "pgmdep" , HasArg (writeIORef pgm_dep) ) , ( "pgmL" , HasArg (writeIORef pgm_L) )