-{-# OPTIONS -W #-}
+{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.51 2000/08/06 12:19:21 panne Exp $
+-- $Id: Main.hs,v 1.63 2000/10/05 13:25:03 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"
GLOBAL_VAR(scale_sizes_by, 1.0, Double)
GLOBAL_VAR(dry_run, False, Bool)
GLOBAL_VAR(recomp, True, Bool)
-GLOBAL_VAR(tmp_prefix, cTMPDIR, String)
+GLOBAL_VAR(tmpdir, cDEFAULT_TMPDIR, String)
#if !defined(HAVE_WIN32_DLL_SUPPORT) || defined(DONT_WANT_WIN32_DLL_SUPPORT)
GLOBAL_VAR(static, True, Bool)
#else
= HscC
| HscAsm
| HscJava
+ deriving Eq
GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" &&
(prefixMatch "i386" cTARGETPLATFORM ||
"-fmax-simplifier-iterations2",
"]",
-
"-fsimplify",
"[",
"-fmax-simplifier-iterations2",
"-fstrictness",
"-fcpr-analyse",
"-fworker-wrapper",
+ "-fglom-binds",
"-fsimplify",
"[",
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
case () of
() | null l -> look h
| prefixMatch "#" l -> look h
- | prefixMatch "{-# LINE" l -> look h
+ | prefixMatch "{-# LINE" l -> look h -- -}
| Just (opts:_) <- matchRegex optionRegex l
-> return (words opts)
| otherwise -> return []
-optionRegex = mkRegex "{-#[ \t]+OPTIONS[ \t]+(.*)#-}"
+optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}" -- -}
-----------------------------------------------------------------------------
-- Main loop
-- grab any -B options from the command line first
argv' <- setTopDir argv
+ -- check whether TMPDIR is set in the environment
+ IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
+ writeIORef tmpdir dir)
+
-- read the package configuration
conf_file <- readIORef package_config
contents <- readFile conf_file
-- find the phase to stop after (i.e. -E, -C, -c, -S flags)
(flags2, todo, stop_flag) <- getToDo argv'
+ writeIORef v_todo todo
-- process all the other arguments, and get the source files
srcs <- processArgs driver_opts flags2 []
data ToDo = DoMkDependHS | DoMkDLL | StopBefore Phase | DoLink
deriving (Eq)
+GLOBAL_VAR(v_todo, error "todo", ToDo)
+
todoFlag :: String -> Maybe ToDo
todoFlag "-M" = Just $ DoMkDependHS
todoFlag "-E" = Just $ StopBefore Hsc
let
----------- ----- ---- --- -- -- - - -
- start_phase = startPhase suffix
-
(_basename, suffix) = splitFilename filename
+ start_phase = startPhase suffix
+
haskell_ish_file = suffix `elem` [ "hs", "lhs", "hc" ]
c_ish_file = suffix `elem` [ "c", "s", "S" ] -- maybe .cc et al.??
- -- hack for .hc files
- real_lang | suffix == "hc" = HscC
- | otherwise = lang
+ -- for a .hc file, or if the -C flag is given, we need to force lang to HscC
+ real_lang
+ | suffix == "hc" = HscC
+ | todo == StopBefore HCc && lang /= HscC && haskell_ish_file = HscC
+ | otherwise = lang
+ let
+ ----------- ----- ---- --- -- -- - - -
pipeline
| todo == DoMkDependHS = [ Unlit, Cpp, MkDependHS ]
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
newTempName extn = do
x <- getProcessID
- tmp_dir <- readIORef tmp_prefix
+ tmp_dir <- readIORef tmpdir
findTempName tmp_dir x
where findTempName tmp_dir x = do
let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
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:
-----------------------------------------------------------------------------
-- Hsc phase
-run_phase Hsc basename _suff input_fn output_fn
+run_phase Hsc basename suff input_fn output_fn
= do hsc <- readIORef pgm_C
-- we add the current directory (i.e. the directory in which
Nothing -> [ "-hidir="++current_dir, "-hisuf="++hisuf ]
Just fn -> [ "-hifile="++fn ]
+ -- 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
+ 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
+ else do t2 <- getModificationTime o_file
+ if t2 > t1
+ then return "-fsource-unchanged"
+ else return ""
+
-- run the compiler!
run_something "Haskell Compiler"
(unwords (hsc : input_fn : (
hsc_opts
++ hi_flags
++ [
+ source_unchanged,
"-ofile="++output_fn,
"-F="++tmp_stub_c,
"-FH="++tmp_stub_h
++ 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 " ++ output_fn)
+ 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
= do splitter <- readIORef pgm_s
-- this is the prefix used for the split .s files
- tmp_pfx <- readIORef tmp_prefix
+ tmp_pfx <- readIORef tmpdir
x <- getProcessID
let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
writeIORef split_prefix split_s_prefix
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
, ( "caf-all" , NoArg (addOpt_C "-fauto-sccs-on-individual-cafs") )
-- "ignore-sccs" doesn't work (ToDo)
+ , ( "no-auto-dicts" , NoArg (addAntiOpt_C "-fauto-sccs-on-dicts") )
+ , ( "no-auto-all" , NoArg (addAntiOpt_C "-fauto-sccs-on-all-toplevs") )
+ , ( "no-auto" , NoArg (addAntiOpt_C "-fauto-sccs-on-exported-toplevs") )
+ , ( "no-caf-all" , NoArg (addAntiOpt_C "-fauto-sccs-on-individual-cafs") )
+
------- Miscellaneous -----------------------------------------------
, ( "cpp" , NoArg (updateState (\s -> s{ cpp_flag = True })) )
, ( "#include" , HasArg (addCmdlineHCInclude) )
, ( "o" , SepArg (writeIORef output_file . Just) )
, ( "osuf" , HasArg (writeIORef output_suf . Just) )
, ( "hisuf" , HasArg (writeIORef hi_suf) )
- , ( "tmpdir" , HasArg (writeIORef tmp_prefix . (++ "/")) )
+ , ( "tmpdir" , HasArg (writeIORef tmpdir . (++ "/")) )
, ( "ohi" , HasArg (\s -> case s of
"-" -> writeIORef hi_on_stdout True
_ -> writeIORef output_hi (Just s)) )
remove_spaces :: String -> String
remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
+
+-----------------------------------------------------------------------------
+-- compatibility code
+
+#if __GLASGOW_HASKELL__ <= 408
+catchJust = catchIO
+ioErrors = justIoErrors
+#endif
projects / ghc-hetmet.git / blobdiff