{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.58 2000/09/12 13:19:20 simonmar Exp $
+-- $Id: Main.hs,v 1.68 2000/10/11 16:06:38 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"
[ "-fwarn-type-defaults"
, "-fwarn-name-shadowing"
, "-fwarn-missing-signatures"
+ , "-fwarn-hi-shadowing"
]
data WarningState = W_default | W_ | W_all | W_not
"-fmax-simplifier-iterations2",
"]",
-
"-fsimplify",
"[",
"-fmax-simplifier-iterations2",
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"), [Package])
-GLOBAL_VAR(package_details, (error "package_details"), [(String,Package)])
+lookupPkg :: String -> [Package] -> Maybe Package
+lookupPkg nm ps
+ = case [p | p <- ps, name p == nm] of
+ [] -> Nothing
+ (p:_) -> Just p
-----------------------------------------------------------------------------
-- Ways
[ ]),
(WayPar, Way "mp" "Parallel"
- [ "-fstack-check"
- , "-fparallel"
+ [ "-fparallel"
, "-D__PARALLEL_HASKELL__"
, "-optc-DPAR"
, "-package concurrent"
, "-fvia-C" ]),
(WayGran, Way "mg" "Gransim"
- [ "-fstack-check"
- , "-fgransim"
+ [ "-fgransim"
, "-D__GRANSIM__"
, "-optc-DGRAN"
, "-package concurrent"
argv' <- setTopDir argv
-- check whether TMPDIR is set in the environment
+#ifndef mingw32_TARGET_OS
IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
writeIORef tmpdir dir)
+#endif
-- read the package configuration
conf_file <- readIORef package_config
-- what the suffix of the intermediate files should be, etc.
-- The following compilation pipeline algorithm is fairly hacky. A
--- better way to do this would be to express the whole comilation as a
+-- better way to do this would be to express the whole compilation as a
-- data flow DAG, where the nodes are the intermediate files and the
-- edges are the compilation phases. This framework would also work
--- nicely if a haskell dependency generator was included in the
+-- nicely if a Haskell dependency generator were included in the
-- driver.
-- It would also deal much more cleanly with compilation phases that
-- the host machine. For example, when compiling two Haskell files
-- where one depends on the other, the data flow graph would determine
-- that the C compiler from the first comilation can be overlapped
--- with the hsc comilation for the second file.
+-- with the hsc compilation for the second file.
data IntermediateFileType
= Temporary
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:
-- build the hsc command line
hsc_opts <- build_hsc_opts
- doing_hi <- readIORef produceHi
- tmp_hi_file <- if doing_hi
- then do fn <- newTempName "hi"
- add files_to_clean fn
- return fn
- else return ""
-
-- deal with -Rghc-timing
timing <- readIORef collect_ghc_timing
stat_file <- newTempName "stat"
-- figure out if the source has changed, for recompilation avoidance.
-- only do this if we're eventually going to generate a .o file.
-- (ToDo: do when generating .hc files too?)
+ --
+ -- Setting source_unchanged to "-fsource_unchanged" means that M.o seems
+ -- to be up to date wrt M.hs; so no need to recompile unless imports have
+ -- changed (which the compiler itself figures out).
+ -- Setting source_unchanged to "" tells the compiler that M.o is out of
+ -- 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 do_recomp && ( todo == DoLink || todo == StopBefore Ln )
- then do t1 <- getModificationTime (basename ++ '.':suff)
- o_file <- odir_ify (basename ++ '.':phase_input_ext Ln)
- t2 <- getModificationTime o_file
- if t2 > t1
- then return "-fsource-unchanged"
- else return ""
- else return ""
+ if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
+ then return ""
+ else do t1 <- getModificationTime (basename ++ '.':suff)
+ o_file_exists <- doesFileExist o_file
+ if not o_file_exists
+ then return "" -- Need to recompile
+ else do t2 <- getModificationTime o_file
+ if t2 > t1
+ then return "-fsource-unchanged"
+ else return ""
-- run the compiler!
run_something "Haskell Compiler"
++ 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