{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.59 2000/09/14 08:17:54 simonpj Exp $
+-- $Id: Main.hs,v 1.64 2000/10/05 13:27:54 simonmar Exp $
--
-- GHC Driver program
--
-----------------------------------------------------------------------------
-- Usage Message
-short_usage = "Usage: For basic information, try the `-help' option."
+short_usage = "Usage: For basic information, try the `--help' option."
long_usage = do
let usage_file = "ghc-usage.txt"
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
(\_ -> 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
+ case lookupPkg package pkg_details of
Nothing -> throwDyn (OtherError ("unknown package name: " ++ package))
Just details -> do
ps <- readIORef packages
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
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 orig_suffix 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_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
run_something "Literate pre-processor"
("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
+ return True
-------------------------------------------------------------------------------
-- Cpp phase
++ [ "-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
mapM genDep [ d | Just d <- deps ]
- return ()
+ return True
-- add the lines to dep_makefile:
-- always:
-- 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)
source_unchanged <-
if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
then return ""
else do t1 <- getModificationTime (basename ++ '.':suff)
- o_file <- odir_ify (basename ++ '.':phase_input_ext Ln)
o_file_exists <- doesFileExist o_file
if not o_file_exists
then return "" -- Need to recompile
++ 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"
add ld_inputs (basename++"_stub.o")
)
+ return True
-----------------------------------------------------------------------------
-- Cc phase
++ pkg_extra_cc_opts
-- ++ [">", ccout]
))
+ return True
-- ToDo: postprocess the output from gcc
++ [ input_fn, output_fn ]
++ machdep_opts
))
+ return True
-----------------------------------------------------------------------------
-- Splitting phase
s <- readFile n_files
let n = read s :: Int
writeIORef n_split_files n
+ return True
-----------------------------------------------------------------------------
-- As phase
++ cmdline_include_flags
++ [ "-c", input_fn, "-o", output_fn ]
))
+ return True
run_phase SplitAs basename _suff _input_fn _output_fn
= do as <- readIORef pgm_a
))
mapM_ assemble_file [1..n]
+ return True
-----------------------------------------------------------------------------
-- Linking
projects / ghc-hetmet.git / blobdiff