-{-# OPTIONS -W #-}
+{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.48 2000/08/04 09:02:56 simonmar Exp $
+-- $Id: Main.hs,v 1.65 2000/10/09 09:19:16 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"
mapM_ blowAway fs
-----------------------------------------------------------------------------
--- Which phase to stop at
-
-endPhaseFlag :: String -> Maybe Phase
-endPhaseFlag "-M" = Just MkDependHS
-endPhaseFlag "-E" = Just Cpp
-endPhaseFlag "-C" = Just Hsc
-endPhaseFlag "-S" = Just Mangle
-endPhaseFlag "-c" = Just As
-endPhaseFlag _ = Nothing
-
-getStopAfter :: [String]
- -> IO ( [String] -- rest of command line
- , Phase -- stop after phase
- , String -- "stop after" flag
- , Bool -- do linking?
- )
-getStopAfter flags
- = case my_partition endPhaseFlag flags of
- ([] , rest) -> return (rest, Ln, "", True) -- default is to do linking
- ([(flag,one)], rest) -> return (rest, one, flag, False)
- (_ , _ ) ->
- throwDyn (OtherError "only one of the flags -M, -E, -C, -S, -c is allowed")
-
------------------------------------------------------------------------------
-- Global compilation flags
-- Cpp-related flags
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 ||
[ "-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",
"-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
getPackageIncludePath :: IO [String]
getPackageIncludePath = do
- ps <- readIORef packages
+ ps <- readIORef packages
ps' <- getPackageDetails ps
return (nub (filter (not.null) (concatMap include_dirs ps')))
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
-> IO [String] -- options, if any
getOptionsFromSource file
= do h <- openFile file ReadMode
- catchIO justIoErrors (look h)
+ catchJust ioErrors (look h)
(\e -> if isEOFError e then return [] else ioError e)
where
look h = do
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
writeIORef package_details (read contents)
-- find the phase to stop after (i.e. -E, -C, -c, -S flags)
- (flags2, stop_phase, stop_flag, do_linking) <- getStopAfter argv'
+ (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 []
when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))
-- mkdependHS is special
- when (stop_phase == MkDependHS) beginMkDependHS
+ when (todo == DoMkDependHS) beginMkDependHS
-- for each source file, find which phases to run
- pipelines <- mapM (genPipeline stop_phase stop_flag) srcs
+ pipelines <- mapM (genPipeline todo stop_flag) srcs
let src_pipelines = zip srcs pipelines
o_file <- readIORef output_file
- if isJust o_file && not do_linking && length srcs > 1
+ if isJust o_file && todo /= DoLink && length srcs > 1
then throwDyn (UsageError "can't apply -o option to multiple source files")
else do
saved_driver_state <- readIORef driver_state
let compileFile (src, phases) = do
- r <- run_pipeline phases src do_linking True orig_base orig_suff
+ r <- run_pipeline phases src (todo==DoLink) True orig_base orig_suff
writeIORef driver_state saved_driver_state
return r
where (orig_base, orig_suff) = splitFilename src
o_files <- mapM compileFile src_pipelines
- when (stop_phase == MkDependHS) endMkDependHS
+ when (todo == DoMkDependHS) endMkDependHS
+
+ when (todo == DoLink) (do_link o_files)
+
+
+-----------------------------------------------------------------------------
+-- Which phase to stop at
+
+data ToDo = DoMkDependHS | DoMkDLL | StopBefore Phase | DoLink
+ deriving (Eq)
+
+GLOBAL_VAR(v_todo, error "todo", ToDo)
- when do_linking (do_link o_files)
+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
+
+getToDo :: [String]
+ -> IO ( [String] -- rest of command line
+ , ToDo -- phase to stop at
+ , String -- "stop at" 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")
-----------------------------------------------------------------------------
-- genPipeline
startPhase _ = Ln -- all unknown file types
genPipeline
- :: Phase -- stop after this phase
+ :: ToDo -- when to stop
-> String -- "stop after" flag (for error messages)
-> String -- original filename
-> IO [ -- list of phases to run for this file
String) -- output file suffix
]
-genPipeline stop_after stop_after_flag filename
+genPipeline todo stop_flag filename
= do
split <- readIORef split_object_files
mangle <- readIORef do_asm_mangling
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
- | stop_after == MkDependHS = [ Unlit, Cpp, MkDependHS ]
+ | todo == DoMkDependHS = [ Unlit, Cpp, MkDependHS ]
| haskell_ish_file =
case real_lang of
++ filename))
else do
- -- this might happen, eg. ghc -S Foo.o
- if stop_after /= Ln && stop_after `notElem` pipeline
- && (stop_after /= As || SplitAs `notElem` pipeline)
- then throwDyn (OtherError ("flag " ++ stop_after_flag
- ++ " is incompatible with source file `"
- ++ filename ++ "'"))
- else do
-
+ -- if we can't find the phase we're supposed to stop before,
+ -- something has gone wrong.
+ case todo of
+ StopBefore phase ->
+ when (phase /= Ln
+ && phase `notElem` pipeline
+ && not (phase == As && SplitAs `elem` pipeline)) $
+ throwDyn (OtherError
+ ("flag " ++ stop_flag
+ ++ " is incompatible with source file `" ++ filename ++ "'"))
+ _ -> return ()
let
----------- ----- ---- --- -- -- - - -
annotatePipeline
- :: [Phase] -> Phase
+ :: [Phase] -- raw pipeline
+ -> Phase -- phase to stop before
-> [(Phase, IntermediateFileType, String{-file extension-})]
annotatePipeline [] _ = []
annotatePipeline (Ln:_) _ = []
: annotatePipeline (next_phase:ps) stop
where
keep_this_output
- | phase == stop = Persistent
+ | next_phase == stop = Persistent
| otherwise =
case next_phase of
Ln -> Persistent
-- the suffix on an output file is determined by the next phase
-- in the pipeline, so we add linking to the end of the pipeline
-- to force the output from the final phase to be a .o file.
- annotated_pipeline = annotatePipeline (pipeline ++ [ Ln ]) stop_after
+ stop_phase = case todo of StopBefore phase -> phase
+ DoMkDependHS -> Ln
+ DoLink -> Ln
+ annotated_pipeline = annotatePipeline (pipeline ++ [ Ln ]) stop_phase
phase_ne p (p1,_,_) = (p1 /= p)
----------- ----- ---- --- -- -- - - -
return $
dropWhile (phase_ne start_phase) .
- foldr (\p ps -> if phase_ne stop_after p then p:ps else [p]) []
+ foldr (\p ps -> if phase_ne stop_phase p then p:ps else []) []
$ annotated_pipeline
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
then return ()
else chuck
- catchIO justIoErrors slurp
+ catchJust ioErrors slurp
(\e -> if isEOFError e then return () else ioError e)
- catchIO justIoErrors chuck
+ catchJust ioErrors chuck
(\e -> if isEOFError e then return () else ioError e)
hPutStrLn tmp_hdl l
slurp
- catchIO justIoErrors slurp
+ catchJust ioErrors slurp
(\e -> if isEOFError e then return () else ioError e)
hClose hdl
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
+ 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_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 " ++ o_file)
+ return False
+ else do -- carry on...
+
-- Generate -Rghc-timing info
when (timing) (
run_something "Generate timing stats"
])
-- compile the _stub.c file w/ gcc
- pipeline <- genPipeline As "" stub_c
+ pipeline <- genPipeline (StopBefore Ln) "" stub_c
run_pipeline pipeline stub_c False{-no linking-}
False{-no -o option-}
(basename++"_stub") "c"
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