From 4ba55934c50379cba5650ddd84d9326a55722047 Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 11 Oct 2000 14:08:52 +0000 Subject: [PATCH] [project @ 2000-10-11 14:08:52 by simonmar] getting there... --- ghc/compiler/main/CmdLineOpts.lhs | 2 +- ghc/compiler/main/DriverState.hs | 24 +++++---- ghc/compiler/main/DriverUtil.hs | 60 ++++++++++------------- ghc/compiler/main/Main.hs | 98 +++++++++++++++++++++++-------------- 4 files changed, 101 insertions(+), 83 deletions(-) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 9d6b18d..7b68e68 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -160,7 +160,7 @@ import Array ( array, (//) ) import GlaExts import Argv import Constants -- Default values for some flags -import DriverUtil +import Util import Maybes ( firstJust ) import Panic ( panic ) diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index 15d630d..70ae73f 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $ +-- $Id: DriverState.hs,v 1.2 2000/10/11 14:08:52 simonmar Exp $ -- -- Settings for the driver -- @@ -94,6 +94,10 @@ cHaskell1Version = "5" -- i.e., Haskell 98 ----------------------------------------------------------------------------- -- Global compilation flags +-- location of compiler-related files +GLOBAL_VAR(topDir, clibdir, String) +GLOBAL_VAR(inplace, False, Bool) + -- Cpp-related flags hs_source_cpp_opts = global [ "-D__HASKELL1__="++cHaskell1Version @@ -412,7 +416,7 @@ addToDirList ref path ----------------------------------------------------------------------------- -- Packages -GLOBAL_VAR(package_config, (findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")), String) +GLOBAL_VAR(path_package_config, error "path_package_config", String) -- package list is maintained in dependency order packages = global ["std", "rts", "gmp"] :: IORef [String] @@ -652,14 +656,14 @@ way_details = ----------------------------------------------------------------------------- -- Programs for particular phases -GLOBAL_VAR(pgm_L, findFile "unlit" cGHC_UNLIT, String) -GLOBAL_VAR(pgm_P, cRAWCPP, String) -GLOBAL_VAR(pgm_C, findFile "hsc" cGHC_HSC, String) -GLOBAL_VAR(pgm_c, cGCC, String) -GLOBAL_VAR(pgm_m, findFile "ghc-asm" cGHC_MANGLER, String) -GLOBAL_VAR(pgm_s, findFile "ghc-split" cGHC_SPLIT, String) -GLOBAL_VAR(pgm_a, cGCC, String) -GLOBAL_VAR(pgm_l, cGCC, String) +GLOBAL_VAR(pgm_L, error "pgm_L", String) +GLOBAL_VAR(pgm_P, cRAWCPP, String) +GLOBAL_VAR(pgm_C, error "pgm_L", String) +GLOBAL_VAR(pgm_c, cGCC, String) +GLOBAL_VAR(pgm_m, error "pgm_m", String) +GLOBAL_VAR(pgm_s, error "pgm_s", String) +GLOBAL_VAR(pgm_a, cGCC, String) +GLOBAL_VAR(pgm_l, cGCC, String) GLOBAL_VAR(opt_dep, [], [String]) GLOBAL_VAR(anti_opt_C, [], [String]) diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs index 75cda59..69173aa 100644 --- a/ghc/compiler/main/DriverUtil.hs +++ b/ghc/compiler/main/DriverUtil.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverUtil.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $ +-- $Id: DriverUtil.hs,v 1.2 2000/10/11 14:08:52 simonmar Exp $ -- -- Utils for the driver -- @@ -17,6 +17,7 @@ import Util import IOExts import Exception import Dynamic +import RegexString import IO import System @@ -30,9 +31,10 @@ import Monad short_usage = "Usage: For basic information, try the `--help' option." +GLOBAL_VAR(path_usage, "", String) + long_usage = do - let usage_file = "ghc-usage.txt" - usage_path = findFile usage_file (cGHC_DRIVER_DIR ++ '/':usage_file) + usage_path <- readIORef path_usage usage <- readFile usage_path dump usage exitWith ExitSuccess @@ -70,28 +72,27 @@ instance Typeable BarfKind where typeOf _ = mkAppTy barfKindTc [] ----------------------------------------------------------------------------- --- Finding files in the installation - -GLOBAL_VAR(topDir, clibdir, String) - - -- grab the last -B option on the command line, and - -- set topDir to its value. -setTopDir :: [String] -> IO [String] -setTopDir args = do - let (minusbs, others) = partition (prefixMatch "-B") args - (case minusbs of - [] -> writeIORef topDir clibdir - some -> writeIORef topDir (drop 2 (last some))) - return others - -findFile name alt_path = unsafePerformIO (do - top_dir <- readIORef topDir - let installed_file = top_dir ++ '/':name - let inplace_file = top_dir ++ '/':cCURRENT_DIR ++ '/':alt_path - b <- doesFileExist inplace_file - if b then return inplace_file - else return installed_file - ) +-- Reading OPTIONS pragmas + +getOptionsFromSource + :: String -- input file + -> IO [String] -- options, if any +getOptionsFromSource file + = do h <- openFile file ReadMode + catchJust ioErrors (look h) + (\e -> if isEOFError e then return [] else ioError e) + where + look h = do + l <- hGetLine h + case () of + () | null l -> look h + | prefixMatch "#" l -> look h + | prefixMatch "{-# LINE" l -> look h -- -} + | Just (opts:_) <- matchRegex optionRegex l + -> return (words opts) + | otherwise -> return [] + +optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}" -- -} ----------------------------------------------------------------------------- -- Utils @@ -111,15 +112,6 @@ 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 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 9d82e36..2671dd7 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,6 +1,6 @@ {-# OPTIONS -W -fno-warn-incomplete-patterns #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.2 2000/10/11 11:54:58 simonmar Exp $ +-- $Id: Main.hs,v 1.3 2000/10/11 14:08:52 simonmar Exp $ -- -- GHC Driver program -- @@ -196,33 +196,9 @@ makeHiMap where add_dir hisuf dir str = dir ++ "%." ++ hisuf ++ split_marker : str - -getOptionsFromSource - :: String -- input file - -> IO [String] -- options, if any -getOptionsFromSource file - = do h <- openFile file ReadMode - catchJust ioErrors (look h) - (\e -> if isEOFError e then return [] else ioError e) - where - look h = do - l <- hGetLine h - case () of - () | null l -> look h - | prefixMatch "#" l -> look h - | prefixMatch "{-# LINE" l -> look h -- -} - | Just (opts:_) <- matchRegex optionRegex l - -> return (words opts) - | otherwise -> return [] - -optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}" -- -} - ----------------------------------------------------------------------------- -- Main loop -get_source_files :: [String] -> ([String],[String]) -get_source_files = partition (('-' /=) . head) - main = -- all error messages are propagated as exceptions my_catchDyn (\dyn -> case dyn of @@ -259,9 +235,41 @@ main = -- grab any -B options from the command line first argv' <- setTopDir argv + top_dir <- readIORef topDir + + let installed s = top_dir ++ s + inplace s = top_dir ++ '/':cCURRENT_DIR ++ '/':s + + installed_pkgconfig = installed ("package.conf") + inplace_pkgconfig = inplace (cGHC_DRIVER_DIR ++ "/package.conf.inplace") + + -- discover whether we're running in a build tree or in an installation, + -- by looking for the package configuration file. + am_installed <- doesFileExist installed_pkgconfig + + if am_installed + then writeIORef path_pkgconfig installed_pkgconfig + else do am_inplace <- doesFileExist inplace_pkgconfig + if am_inplace + then writeIORef path_pkgconfig inplace_pkgconfig + else throw (OtherError "can't find package.conf") + + -- set the location of our various files + if am_installed + then do writeIORef path_usage (installed "ghc-usage.txt") + writeIORef pgm_L (installed "unlit") + writeIORef pgm_C (installed "hsc") + writeIORef pgm_m (installed "ghc-asm") + writeIORef pgm_s (installed "ghc-split") + + else do writeIORef path_usage (inplace (cGHC_DRIVER_DIR ++ '/':usage_file)) + writeIORef pgm_L (inplace cGHC_UNLIT) + writeIORef pgm_C (inplace cGHC_HSC) + writeIORef pgm_m (inplace cGHC_MANGLER) + writeIORef pgm_s (inplace cGHC_SPLIT) -- read the package configuration - conf_file <- readIORef package_config + conf_file <- readIORef path_pkgconfig contents <- readFile conf_file writeIORef package_details (read contents) @@ -292,14 +300,16 @@ main = when verb (do hPutStr stderr "Glasgow Haskell Compiler, Version " hPutStr stderr version_str hPutStr stderr ", for Haskell 98, compiled by GHC version " - hPutStr stderr booter_version - hPutStr stderr "\n") + hPutStrLn stderr booter_version) when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file)) -- mkdependHS is special when (todo == DoMkDependHS) beginMkDependHS + -- make is special + when (todo == DoMake) beginMake + -- for each source file, find which phases to run pipelines <- mapM (genPipeline todo stop_flag) srcs let src_pipelines = zip srcs pipelines @@ -328,34 +338,46 @@ main = when (todo == DoLink) (do_link o_files) + -- grab the last -B option on the command line, and + -- set topDir to its value. +setTopDir :: [String] -> IO [String] +setTopDir args = do + let (minusbs, others) = partition (prefixMatch "-B") args + (case minusbs of + [] -> writeIORef topDir clibdir + some -> writeIORef topDir (drop 2 (last some))) + return others ----------------------------------------------------------------------------- -- Which phase to stop at -data ToDo = DoMkDependHS | DoMkDLL | StopBefore Phase | DoLink +data ToDo = DoMkDependHS | DoMkDLL | StopBefore Phase | DoLink | DoInteractive 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 +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 "--make" = Just $ DoMake +todoFlag "--interactive" = Just $ DoInteractive +todoFlag _ = Nothing getToDo :: [String] -> IO ( [String] -- rest of command line - , ToDo -- phase to stop at - , String -- "stop at" flag + , ToDo + , String -- "ToDo" 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") + throwDyn (OtherError + "only one of the flags -M, -E, -C, -S, -c, --make is allowed") ----------------------------------------------------------------------------- -- genPipeline -- 1.7.10.4