Commit a84cc2cd authored by simonmar's avatar simonmar
Browse files

[project @ 2000-07-27 10:26:04 by simonmar]

Cleanup of the compilation pipeline.  Now the list of phases to run
for each filename is generated statically, rather than on-the-fly.

Things should be more robust; some nonsense combinations of flags and
input files are now thrown out.
parent 023fea0f
......@@ -87,6 +87,7 @@ version_str = cProjectVersion ++
( if cProjectPatchLevel /= "0" && cProjectPatchLevel /= ""
then '.':cProjectPatchLevel
else "")
-- umm, isn't the patchlevel included in the version number? --SDM
-----------------------------------------------------------------------------
-- Phases
......@@ -115,9 +116,7 @@ data Phase
| SplitAs
| As
| Ln
deriving (Eq,Ord,Enum,Ix,Show,Bounded)
initial_phase = Unlit
deriving (Eq)
-----------------------------------------------------------------------------
-- Errors
......@@ -182,11 +181,11 @@ cleanTempFiles = do
verb <- readIORef verbose
let blowAway f =
(do on verb (hPutStrLn stderr ("removing: " ++ f))
(do when verb (hPutStrLn stderr ("removing: " ++ f))
if '*' `elem` f then system ("rm -f " ++ f) >> return ()
else removeFile f)
`catchAllIO`
(\e -> on verb (hPutStrLn stderr
(\e -> when verb (hPutStrLn stderr
("warning: can't remove tmp file" ++ f)))
mapM_ blowAway fs
......@@ -195,23 +194,24 @@ cleanTempFiles = do
GLOBAL_VAR(stop_after, Ln, Phase)
end_phase_flag :: String -> Maybe Phase
end_phase_flag "-M" = Just MkDependHS
end_phase_flag "-E" = Just Cpp
end_phase_flag "-C" = Just Hsc
end_phase_flag "-S" = Just Mangle
end_phase_flag "-c" = Just As
end_phase_flag _ = Nothing
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 end_phase_flag flags of
([] , rest) -> return (rest, As, True)
([one], rest) -> return (rest, one, False)
= case my_partition endPhaseFlag flags of
([] , rest) -> return (rest, As, "", True)
([(flag,one)], rest) -> return (rest, one, flag, False)
(_ , rest) -> throwDyn AmbiguousPhase
-----------------------------------------------------------------------------
......@@ -366,7 +366,7 @@ setOptLevel "not" = writeIORef opt_level 0
setOptLevel [c] | isDigit c = do
let level = ord c - ord '0'
writeIORef opt_level level
on (level >= 1) go_via_C
when (level >= 1) go_via_C
setOptLevel s = throwDyn (UnknownFlag ("-O"++s))
go_via_C = do
......@@ -1074,41 +1074,6 @@ optionRegex = mkRegex "{-#[ \t]+OPTIONS[ \t]+(.*)#-}"
get_source_files :: [String] -> ([String],[String])
get_source_files = partition (('-' /=) . head)
suffixes :: [(String,Phase)]
suffixes =
[ ("lhs", Unlit)
, ("hs", Cpp)
, ("hc", HCc)
, ("c", Cc)
, ("raw_s", Mangle)
, ("s", As)
, ("S", As)
, ("o", Ln)
]
phase_input_ext Unlit = "lhs"
phase_input_ext Cpp = "lpp"
phase_input_ext Hsc = "cpp"
phase_input_ext HCc = "hc"
phase_input_ext Cc = "c"
phase_input_ext Mangle = "raw_s"
phase_input_ext SplitMangle = "split_s" -- not really generated
phase_input_ext As = "s"
phase_input_ext SplitAs = "split_s" -- not really generated
phase_input_ext Ln = "o"
find_phase :: String -> ([(Phase,String)], [String])
-> ([(Phase,String)], [String])
find_phase f (phase_srcs, unknown_srcs)
= case lookup ext suffixes of
Just the_phase -> ((the_phase,f):phase_srcs, unknown_srcs)
Nothing -> (phase_srcs, f:unknown_srcs)
where (basename,ext) = split_filename f
find_phases srcs = (phase_srcs, unknown_srcs)
where (phase_srcs, unknown_srcs) = foldr find_phase ([],[]) srcs
main =
-- all error messages are propagated as exceptions
my_catchDyn (\dyn -> case dyn of
......@@ -1147,7 +1112,7 @@ main =
writeIORef package_details (read contents)
-- find the phase to stop after (i.e. -E, -C, -c, -S flags)
(flags2, stop_phase, do_linking) <- getStopAfter argv'
(flags2, stop_phase, stop_flag, do_linking) <- getStopAfter argv'
-- process all the other arguments, and get the source files
srcs <- processArgs flags2 []
......@@ -1165,36 +1130,31 @@ main =
then do_mkdependHS flags2 srcs
else do
-- for each source file, find which phase to start at
let (phase_srcs, unknown_srcs) = find_phases srcs
-- for each source file, find which phases to run
pipelines <- mapM (genPipeline stop_phase stop_flag) srcs
let src_pipelines = zip srcs pipelines
o_file <- readIORef output_file
if isJust o_file && not do_linking && length phase_srcs > 1
if isJust o_file && not do_linking && length srcs > 1
then throwDyn MultipleSrcsOneOutput
else do
if null unknown_srcs && null phase_srcs
then throwDyn NoInputFiles
else do
-- if we have unknown files, and we're not doing linking, complain
-- (otherwise pass them through to the linker).
if not (null unknown_srcs) && not do_linking
then throwDyn (UnknownFileType (head unknown_srcs))
else do
if null srcs then throwDyn NoInputFiles else do
let compileFile :: (Phase, String) -> IO String
compileFile (phase, src) = do
let (orig_base, _) = split_filename src
if phase < Ln -- anything to do?
then run_pipeline stop_phase do_linking True orig_base (phase,src)
else return src
let compileFile (src, phases) =
run_pipeline phases src do_linking True orig_base
where (orig_base, _) = splitFilename src
o_files <- mapM compileFile phase_srcs
o_files <- mapM compileFile src_pipelines
when do_linking $
do_link o_files unknown_srcs
when do_linking (do_link o_files)
-----------------------------------------------------------------------------
-- genPipeline
--
-- Herein is all the magic about which phases to run in which order, whether
-- the intermediate files should be in /tmp or in the current directory,
-- 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
......@@ -1216,80 +1176,162 @@ main =
-- that the C compiler from the first comilation can be overlapped
-- with the hsc comilation for the second file.
run_pipeline
:: Phase -- phase to end on (never Linker)
-> Bool -- doing linking afterward?
-> Bool -- take into account -o when generating output?
-> String -- original basename (eg. Main)
-> (Phase, String) -- phase to run, input file
-> IO String -- return final filename
run_pipeline last_phase do_linking use_ofile orig_basename (phase, input_fn)
| phase > last_phase = return input_fn
| otherwise
= do
data IntermediateFileType
= Temporary
| Persistent
deriving (Eq)
-- the first compilation phase for a given file is determined
-- by its suffix.
startPhase "lhs" = Unlit
startPhase "hs" = Cpp
startPhase "hc" = HCc
startPhase "c" = Cc
startPhase "raw_s" = Mangle
startPhase "s" = As
startPhase "S" = As
startPhase "o" = Ln
genPipeline
:: Phase -- stop after this phase
-> String -- "stop after" flag (for error messages)
-> String -- original filename
-> IO [ -- list of phases to run for this file
(Phase,
IntermediateFileType, -- keep the output from this phase?
String) -- output file suffix
]
genPipeline stop_after stop_after_flag filename
= do
split <- readIORef split_object_files
mangle <- readIORef do_asm_mangling
lang <- readIORef hsc_lang
keep_hc <- readIORef keep_hc_files
keep_raw_s <- readIORef keep_raw_s_files
keep_s <- readIORef keep_s_files
let (basename,ext) = split_filename input_fn
let
----------- ----- ---- --- -- -- - - -
start_phase = startPhase suffix
split <- readIORef split_object_files
mangle <- readIORef do_asm_mangling
lang <- readIORef hsc_lang
(basename, suffix) = splitFilename filename
-- figure out what the next phase is. This is
-- straightforward, apart from the fact that hsc can generate
-- either C or assembler direct, and assembly mangling is
-- optional, and splitting involves one extra phase and an alternate
-- assembler.
let next_phase =
case phase of
Hsc -> case lang of
HscC -> HCc
HscAsm | split -> SplitMangle
| otherwise -> As
haskell_ish_file = suffix `elem` [ "hs", "lhs", "hc" ]
c_ish_file = suffix `elem` [ "c", "s", "S" ] -- maybe .cc et al.??
HCc | mangle -> Mangle
| otherwise -> As
pipeline
| haskell_ish_file =
case lang of
HscC | split && mangle -> [ Unlit, Cpp, Hsc, HCc, Mangle,
SplitMangle, SplitAs ]
| mangle -> [ Unlit, Cpp, Hsc, HCc, Mangle, As ]
| split -> not_valid
| otherwise -> [ Unlit, Cpp, Hsc, HCc, As ]
Cc -> As
HscAsm | split -> not_valid
| otherwise -> [ Unlit, Cpp, Hsc, As ]
Mangle | not split -> As
SplitMangle -> SplitAs
SplitAs -> Ln
HscJava | split -> not_valid
| otherwise -> error "not implemented: compiling via Java"
_ -> succ phase
| c_ish_file = [ Cc, As ]
| otherwise = [ ] -- just pass this file through to the linker
-- filename extension for the output, determined by next_phase
let new_ext = phase_input_ext next_phase
-- ToDo: this is somewhat cryptic
not_valid = throwDyn (OtherError ("invalid option combination"))
----------- ----- ---- --- -- -- - - -
-- Figure out what the output from this pass should be called.
-- this shouldn't happen.
if start_phase /= Ln && start_phase `notElem` pipeline
then throwDyn (OtherError ("can't find starting phase for "
++ filename))
else do
-- this might happen, eg. ghc -S Foo.o
if stop_after /= As && stop_after `notElem` pipeline
then throwDyn (OtherError ("flag " ++ stop_after_flag
++ " is incompatible with source file "
++ filename))
else do
-- If we're keeping the output from this phase, then we just save
-- it in the current directory, otherwise we generate a new temp file.
keep_s <- readIORef keep_s_files
keep_raw_s <- readIORef keep_raw_s_files
keep_hc <- readIORef keep_hc_files
let keep_this_output =
case next_phase of
Ln -> True
Mangle | keep_raw_s -> True -- first enhancement :)
As | keep_s -> True
HCc | keep_hc -> True
_other -> False
let
----------- ----- ---- --- -- -- - - -
annotatePipeline
:: [Phase] -> Phase
-> [(Phase, IntermediateFileType, String{-file extension-})]
annotatePipeline [] _ = []
annotatePipeline (Ln:_) _ = []
annotatePipeline (phase:next_phase:ps) stop =
(phase, keep_this_output, phase_input_ext next_phase)
: annotatePipeline (next_phase:ps) stop
where
keep_this_output
| phase == stop = Persistent
| otherwise =
case next_phase of
Ln -> Persistent
Mangle | keep_raw_s -> Persistent
As | keep_s -> Persistent
HCc | keep_hc -> Persistent
_other -> Temporary
-- add information about output files to the pipeline
-- 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
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]) []
$ annotated_pipeline
-- the output suffix for a given phase is uniquely determined by
-- the input requirements of the next phase.
phase_input_ext Unlit = "lhs"
phase_input_ext Cpp = "lpp"
phase_input_ext Hsc = "cpp"
phase_input_ext HCc = "hc"
phase_input_ext Cc = "c"
phase_input_ext Mangle = "raw_s"
phase_input_ext SplitMangle = "split_s" -- not really generated
phase_input_ext As = "s"
phase_input_ext SplitAs = "split_s" -- not really generated
phase_input_ext Ln = "o"
run_pipeline
:: [ (Phase, IntermediateFileType, String) ] -- phases to run
-> String -- input file
-> Bool -- doing linking afterward?
-> Bool -- take into account -o when generating output?
-> String -- original basename (eg. Main)
-> IO String -- return final filename
run_pipeline [] input_fn _ _ _ = return input_fn
run_pipeline ((phase, keep, o_suffix):phases)
input_fn do_linking use_ofile orig_basename
= do
output_fn <-
(if next_phase > last_phase && not do_linking && use_ofile
(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 ++ '.':new_ext)
f <- odir_ify (orig_basename ++ '.':o_suffix)
osuf_ify f
-- .o files are always kept. .s files and .hc file may be kept.
else if keep_this_output
then odir_ify (orig_basename ++ '.':new_ext)
else do filename <- newTempName new_ext
else if keep == Persistent
then odir_ify (orig_basename ++ '.':o_suffix)
else do filename <- newTempName o_suffix
add files_to_clean filename
return filename
)
......@@ -1298,12 +1340,11 @@ run_pipeline last_phase do_linking use_ofile orig_basename (phase, input_fn)
-- sadly, ghc -E is supposed to write the file to stdout. We
-- generate <file>.cpp, so we also have to cat the file here.
when (next_phase > last_phase && last_phase == Cpp) $
when (null phases && phase == Cpp) $
run_something "Dump pre-processed file to stdout"
("cat " ++ output_fn)
run_pipeline last_phase do_linking use_ofile
orig_basename (next_phase, output_fn)
run_pipeline phases output_fn do_linking use_ofile orig_basename
-- find a temporary name that doesn't already exist.
......@@ -1445,7 +1486,7 @@ run_phase Hsc basename input_fn output_fn
)))
-- Generate -Rghc-timing info
on (timing) (
when (timing) (
run_something "Generate timing stats"
(findFile "ghc-stats" cGHC_STATS ++ ' ':stat_file)
)
......@@ -1456,7 +1497,7 @@ run_phase Hsc basename input_fn output_fn
-- copy .h_stub file into current dir if present
b <- doesFileExist tmp_stub_h
on b (do
when b (do
run_something "Copy stub .h file"
("cp " ++ tmp_stub_h ++ ' ':stub_h)
......@@ -1472,10 +1513,10 @@ run_phase Hsc basename input_fn output_fn
])
-- compile the _stub.c file w/ gcc
run_pipeline As False{-no linking-}
pipeline <- genPipeline As "" stub_c
run_pipeline pipeline stub_c False{-no linking-}
False{-no -o option-}
(basename++"_stub")
(Cc, stub_c)
add ld_inputs (basename++"_stub.o")
)
......@@ -1649,8 +1690,8 @@ run_phase SplitAs basename input_fn output_fn
-----------------------------------------------------------------------------
-- Linking
do_link :: [String] -> [String] -> IO ()
do_link o_files unknown_srcs = do
do_link :: [String] -> IO ()
do_link o_files = do
ln <- readIORef pgm_l
verb <- is_verbose
o_file <- readIORef output_file
......@@ -1681,7 +1722,6 @@ do_link o_files unknown_srcs = do
(unwords
([ ln, verb, "-o", output_fn ]
++ o_files
++ unknown_srcs
++ extra_ld_inputs
++ lib_path_opts
++ lib_opts
......@@ -1724,7 +1764,7 @@ run_something phase_name cmd
if exit_code /= ExitSuccess
then throwDyn (PhaseFailed phase_name exit_code)
else do on verb (putStr "\n")
else do when verb (putStr "\n")
return ()
-----------------------------------------------------------------------------
......@@ -2042,13 +2082,13 @@ findFile name alt_path = unsafePerformIO (do
-----------------------------------------------------------------------------
-- Utils
my_partition :: (a -> Maybe b) -> [a] -> ([b],[a])
my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
my_partition p [] = ([],[])
my_partition p (a:as)
= let (bs,cs) = my_partition p as in
case p a of
Nothing -> (bs,a:cs)
Just b -> (b:bs,cs)
Just b -> ((a,b):bs,cs)
my_prefix_match :: String -> String -> Maybe String
my_prefix_match [] rest = Just rest
......@@ -2068,16 +2108,14 @@ postfixMatch pat str = prefixMatch (reverse pat) (reverse str)
later = flip finally
on b io = if b then io >> return (error "on") else return (error "on")
my_catch = flip catchAllIO
my_catchDyn = flip catchDyn
global :: a -> IORef a
global a = unsafePerformIO (newIORef a)
split_filename :: String -> (String,String)
split_filename f = (reverse (stripDot rev_basename), reverse rev_ext)
splitFilename :: String -> (String,String)
splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext)
where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
stripDot ('.':xs) = xs
stripDot xs = xs
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment