From a84cc2cdc325175905c004a2ebe310d08387a0bb Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 27 Jul 2000 10:26:04 +0000 Subject: [PATCH] [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. --- ghc/driver/Main.hs | 328 +++++++++++++++++++++++++++++----------------------- 1 file changed, 183 insertions(+), 145 deletions(-) diff --git a/ghc/driver/Main.hs b/ghc/driver/Main.hs index e2f7fa1..472754c 100644 --- a/ghc/driver/Main.hs +++ b/ghc/driver/Main.hs @@ -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 .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 -- 1.7.10.4