Commit 1211c4e5 authored by simonmar's avatar simonmar
Browse files

[project @ 2000-10-11 15:26:18 by simonmar]

all compiles now; not quite hooked up to hscMain yet though.
parent 0cb8c786
-----------------------------------------------------------------------------
-- $Id: DriverFlags.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $
-- $Id: DriverFlags.hs,v 1.2 2000/10/11 15:26:18 simonmar Exp $
--
-- Driver flags
--
......@@ -399,3 +399,95 @@ decodeSize str
floatOpt :: IORef Double -> String -> IO ()
floatOpt ref str
= writeIORef ref (read str :: Double)
-----------------------------------------------------------------------------
-- Build the Hsc static command line opts
build_hsc_opts :: IO [String]
build_hsc_opts = do
opt_C_ <- getStaticOpts opt_C -- misc hsc opts
-- warnings
warn_level <- readIORef warning_opt
let warn_opts = case warn_level of
W_default -> standardWarnings
W_ -> minusWOpts
W_all -> minusWallOpts
W_not -> []
-- optimisation
minus_o <- readIORef opt_level
optimisation_opts <-
case minus_o of
0 -> hsc_minusNoO_flags
1 -> hsc_minusO_flags
2 -> hsc_minusO2_flags
_ -> error "unknown opt level"
-- ToDo: -Ofile
-- STG passes
ways_ <- readIORef ways
let stg_massage | WayProf `elem` ways_ = "-fmassage-stg-for-profiling"
| otherwise = ""
stg_stats <- readIORef opt_StgStats
let stg_stats_flag | stg_stats = "-dstg-stats"
| otherwise = ""
let stg_opts = [ stg_massage, stg_stats_flag, "-flet-no-escape" ]
-- let-no-escape always on for now
-- take into account -fno-* flags by removing the equivalent -f*
-- flag from our list.
anti_flags <- getStaticOpts anti_opt_C
let basic_opts = opt_C_ ++ warn_opts ++ optimisation_opts ++ stg_opts
filtered_opts = filter (`notElem` anti_flags) basic_opts
verb <- is_verbose
let hi_vers = "-fhi-version="++cProjectVersionInt
static <- (do s <- readIORef static; if s then return "-static" else return "")
l <- readIORef hsc_lang
let lang = case l of
HscC -> "-olang=C"
HscAsm -> "-olang=asm"
HscJava -> "-olang=java"
-- get hi-file suffix
hisuf <- readIORef hi_suf
-- hi-suffix for packages depends on the build tag.
package_hisuf <-
do tag <- readIORef build_tag
if null tag
then return "hi"
else return (tag ++ "_hi")
import_dirs <- readIORef import_paths
package_import_dirs <- getPackageImportPath
let hi_map = "-himap=" ++
makeHiMap import_dirs hisuf
package_import_dirs package_hisuf
split_marker
hi_map_sep = "-himap-sep=" ++ [split_marker]
return
(
filtered_opts
++ [ hi_vers, static, verb, lang, hi_map, hi_map_sep ]
)
makeHiMap
(import_dirs :: [String])
(hi_suffix :: String)
(package_import_dirs :: [String])
(package_hi_suffix :: String)
(split_marker :: Char)
= foldr (add_dir hi_suffix)
(foldr (add_dir package_hi_suffix) "" package_import_dirs)
import_dirs
where
add_dir hisuf dir str = dir ++ "%." ++ hisuf ++ split_marker : str
-----------------------------------------------------------------------------
-- $Id: DriverPipeline.hs,v 1.1 2000/10/11 15:26:18 simonmar Exp $
--
-- GHC Driver
--
-- (c) Simon Marlow 2000
--
-----------------------------------------------------------------------------
module DriverPipeline (
GhcMode(..), getGhcMode, v_GhcMode,
genPipeline, runPipeline,
preprocess,
doLink,
) where
#include "HsVersions.h"
import CmSummarise -- for mkdependHS stuff
import DriverState
import DriverUtil
import DriverMkDepend
import DriverFlags
import TmpFiles
import Config
import Util
import CmdLineOpts
import Panic
import IOExts
import Posix
import Exception
import IO
import Monad
import Maybe
-----------------------------------------------------------------------------
-- GHC modes of operation
data GhcMode
= DoMkDependHS -- ghc -M
| DoMkDLL -- ghc -mk-dll
| StopBefore Phase -- ghc -E | -C | -S | -c
| DoMake -- ghc --make
| DoInteractive -- ghc --interactive
| DoLink -- [ the default ]
deriving (Eq)
GLOBAL_VAR(v_GhcMode, error "todo", GhcMode)
modeFlag :: String -> Maybe GhcMode
modeFlag "-M" = Just $ DoMkDependHS
modeFlag "-E" = Just $ StopBefore Hsc
modeFlag "-C" = Just $ StopBefore HCc
modeFlag "-S" = Just $ StopBefore As
modeFlag "-c" = Just $ StopBefore Ln
modeFlag "--make" = Just $ DoMake
modeFlag "--interactive" = Just $ DoInteractive
modeFlag _ = Nothing
getGhcMode :: [String]
-> IO ( [String] -- rest of command line
, GhcMode
, String -- "GhcMode" flag
)
getGhcMode flags
= case my_partition modeFlag 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, --make, --interactive is allowed")
-----------------------------------------------------------------------------
-- Phases
{-
Phase of the | Suffix saying | Flag saying | (suffix of)
compilation system | ``start here''| ``stop after''| output file
literate pre-processor | .lhs | - | -
C pre-processor (opt.) | - | -E | -
Haskell compiler | .hs | -C, -S | .hc, .s
C compiler (opt.) | .hc or .c | -S | .s
assembler | .s or .S | -c | .o
linker | other | - | a.out
-}
data Phase
= MkDependHS -- haskell dependency generation
| Unlit
| Cpp
| Hsc
| Cc
| HCc -- Haskellised C (as opposed to vanilla C) compilation
| Mangle -- assembly mangling, now done by a separate script.
| SplitMangle -- after mangler if splitting
| SplitAs
| As
| Ln
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
startPhase _ = Ln -- all unknown file types
-- 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" -- intermediate only
phase_input_ext Hsc = "cpp" -- intermediate only
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"
phase_input_ext MkDependHS = "dep"
haskellish_suffix = (`elem` [ "hs", "lhs", "hc" ])
cish_suffix = (`elem` [ "c", "s", "S" ]) -- maybe .cc et al.??
haskellish_file f = haskellish_suffix suf where (_,suf) = splitFilename f
cish_file f = cish_suffix suf where (_,suf) = splitFilename f
-----------------------------------------------------------------------------
-- 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
-- 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
-- driver.
-- It would also deal much more cleanly with compilation phases that
-- generate multiple intermediates, (eg. hsc generates .hc, .hi, and
-- possibly stub files), where some of the output files need to be
-- processed further (eg. the stub files need to be compiled by the C
-- compiler).
-- A cool thing to do would then be to execute the data flow graph
-- concurrently, automatically taking advantage of extra processors on
-- 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.
data IntermediateFileType
= Temporary
| Persistent
deriving (Eq)
genPipeline
:: GhcMode -- when to stop
-> 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 todo stop_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, suffix) = splitFilename filename
start_phase = startPhase suffix
haskellish = haskellish_suffix suffix
cish = cish_suffix suffix
-- 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 && haskellish = HscC
| otherwise = lang
let
----------- ----- ---- --- -- -- - - -
pipeline
| todo == DoMkDependHS = [ Unlit, Cpp, MkDependHS ]
| haskellish =
case real_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 ]
HscAsm | split -> [ Unlit, Cpp, Hsc, SplitMangle, SplitAs ]
| otherwise -> [ Unlit, Cpp, Hsc, As ]
HscJava | split -> not_valid
| otherwise -> error "not implemented: compiling via Java"
| cish = [ Cc, As ]
| otherwise = [ ] -- just pass this file through to the linker
-- ToDo: this is somewhat cryptic
not_valid = throwDyn (OtherError ("invalid option combination"))
----------- ----- ---- --- -- -- - - -
-- this shouldn't happen.
if start_phase /= Ln && start_phase `notElem` pipeline
then throwDyn (OtherError ("can't find starting phase for "
++ 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] -- raw pipeline
-> Phase -- phase to stop before
-> [(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
| next_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.
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_phase p then p:ps else []) []
$ annotated_pipeline
runPipeline
:: [ (Phase, IntermediateFileType, String) ] -- phases to run
-> String -- input file
-> Bool -- doing linking afterward?
-> Bool -- take into account -o when generating output?
-> IO String -- return final filename
runPipeline pipeline input_fn do_linking use_ofile
= pipeLoop pipeline input_fn do_linking use_ofile basename suffix
where (basename, suffix) = splitFilename input_fn
pipeLoop [] input_fn _ _ _ _ = return input_fn
pipeLoop ((phase, keep, o_suffix):phases)
input_fn do_linking use_ofile orig_basename orig_suffix
= do
output_fn <- outputFileName (null phases) keep o_suffix
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.
when (null phases && phase == Cpp) $
run_something "Dump pre-processed file to stdout"
("cat " ++ output_fn)
pipeLoop 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 newTempName suffix
-------------------------------------------------------------------------------
-- Unlit phase
run_phase Unlit _basename _suff input_fn output_fn
= do unlit <- readIORef pgm_L
unlit_flags <- getOpts opt_L
run_something "Literate pre-processor"
("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
return True
-------------------------------------------------------------------------------
-- Cpp phase
run_phase Cpp _basename _suff input_fn output_fn
= do src_opts <- getOptionsFromSource input_fn
-- ToDo: this is *wrong* if we're processing more than one file:
-- the OPTIONS will persist through the subsequent compilations.
_ <- processArgs dynamic_flags src_opts []
do_cpp <- readState cpp_flag
if do_cpp
then do
cpp <- readIORef pgm_P
hscpp_opts <- getOpts opt_P
hs_src_cpp_opts <- readIORef hs_source_cpp_opts
cmdline_include_paths <- readIORef include_paths
pkg_include_dirs <- getPackageIncludePath
let include_paths = map (\p -> "-I"++p) (cmdline_include_paths
++ pkg_include_dirs)
verb <- is_verbose
run_something "C pre-processor"
(unwords
(["echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}'", ">", output_fn, "&&",
cpp, verb]
++ include_paths
++ hs_src_cpp_opts
++ hscpp_opts
++ [ "-x", "c", input_fn, ">>", output_fn ]
))
else do
run_something "Ineffective C pre-processor"
("echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}' > "
++ output_fn ++ " && cat " ++ input_fn
++ " >> " ++ output_fn)
return True
-----------------------------------------------------------------------------
-- MkDependHS phase
run_phase MkDependHS basename suff input_fn _output_fn = do
src <- readFile input_fn
let imports = getImports src
deps <- mapM (findDependency basename) imports
osuf_opt <- readIORef output_suf
let osuf = case osuf_opt of
Nothing -> "o"
Just s -> s
extra_suffixes <- readIORef dep_suffixes
let suffixes = osuf : map (++ ('_':osuf)) extra_suffixes
ofiles = map (\suf -> basename ++ '.':suf) suffixes
objs <- mapM odir_ify ofiles
hdl <- readIORef dep_tmp_hdl
-- std dependeny of the object(s) on the source file
hPutStrLn hdl (unwords objs ++ " : " ++ basename ++ '.':suff)
let genDep (dep, False {- not an hi file -}) =
hPutStrLn hdl (unwords objs ++ " : " ++ dep)
genDep (dep, True {- is an hi file -}) = do
hisuf <- readIORef hi_suf
let dep_base = remove_suffix '.' dep
deps = (dep_base ++ hisuf)
: map (\suf -> dep_base ++ suf ++ '_':hisuf) extra_suffixes
-- length objs should be == length deps
sequence_ (zipWith (\o d -> hPutStrLn hdl (o ++ " : " ++ d)) objs deps)
mapM genDep [ d | Just d <- deps ]
return True
-- add the lines to dep_makefile:
-- always:
-- this.o : this.hs
-- if the dependency is on something other than a .hi file:
-- this.o this.p_o ... : dep
-- otherwise
-- if the import is {-# SOURCE #-}
-- this.o this.p_o ... : dep.hi-boot[-$vers]
-- else
-- this.o ... : dep.hi
-- this.p_o ... : dep.p_hi
-- ...
-- (where .o is $osuf, and the other suffixes come from
-- the cmdline -s options).
-----------------------------------------------------------------------------
-- Hsc phase
{-
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
-- the .hs files resides) to the import path, since this is
-- what gcc does, and it's probably what you want.
let current_dir = getdir basename
paths <- readIORef include_paths
writeIORef include_paths (current_dir : paths)
-- build the hsc command line
hsc_opts <- build_hsc_opts
doing_hi <- readIORef produceHi
tmp_hi_file <- if doing_hi
then newTempName "hi"
else return ""
-- tmp files for foreign export stub code
tmp_stub_h <- newTempName "stub_h"
tmp_stub_c <- newTempName "stub_c"
-- figure out where to put the .hi file
ohi <- readIORef output_hi
hisuf <- readIORef hi_suf
let hi_flags = case ohi of
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_GhcMode
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
]
)))
-- check whether compilation was performed, bail out if not