-----------------------------------------------------------------------------
--- $Id: DriverPipeline.hs,v 1.2 2000/10/11 16:26:04 simonmar Exp $
+-- $Id: DriverPipeline.hs,v 1.5 2000/10/23 09:03:27 simonpj Exp $
--
-- GHC Driver
--
-----------------------------------------------------------------------------
module DriverPipeline (
+
+ -- interfaces for the batch-mode driver
GhcMode(..), getGhcMode, v_GhcMode,
genPipeline, runPipeline,
- preprocess,
+
+ -- interfaces for the compilation manager (interpreted/batch-mode)
+ preprocess, compile,
+
+ -- batch-mode linking interface
doLink,
) where
#include "HsVersions.h"
-import CmSummarise -- for mkdependHS stuff
+import CmSummarise
+import CmLink
import DriverState
import DriverUtil
import DriverMkDepend
+import DriverPhases
import DriverFlags
+import Finder
import TmpFiles
+import HscTypes
+import UniqFM
+import Outputable
+import Module
+import ErrUtils
+import CmdLineOpts
import Config
import Util
-import CmdLineOpts
import Panic
+import Directory
+import System
import IOExts
-import Posix
+-- import Posix commented out temp by SLPJ to get going on windows
import Exception
import IO
"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
-- 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
+ | todo == StopBefore HCc && haskellish = HscC
| otherwise = lang
let
annotatePipeline [] _ = []
annotatePipeline (Ln:_) _ = []
annotatePipeline (phase:next_phase:ps) stop =
- (phase, keep_this_output, phase_input_ext next_phase)
+ (phase, keep_this_output, phaseInputExt next_phase)
: annotatePipeline (next_phase:ps) stop
where
keep_this_output
-- 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)
+ o_file <- odir_ify (basename ++ '.':phaseInputExt Ln)
source_unchanged <-
if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
then return ""
-- build a bogus ModSummary to pass to hscMain.
let summary = ModSummary {
- ms_loc = SourceOnly (error "no mod") input_fn,
+ ms_location = error "no loc",
ms_ppsource = Just (loc, error "no fingerprint"),
ms_imports = error "no imports"
}
case result of {
- HscErrs pcs errs warns -> do
- mapM (printSDoc PprForUser) warns
- mapM (printSDoc PprForUser) errs
- throwDyn (PhaseFailed "hsc" (ExitFailure 1));
+ HscErrs pcs errs warns -> do {
+ printErrorsAndWarnings errs warns
+ throwDyn (PhaseFailed "hsc" (ExitFailure 1)) };
- HscOk details maybe_iface maybe_stub_h maybe_stub_c pcs warns -> do
+ HscOK details maybe_iface maybe_stub_h maybe_stub_c pcs warns -> do
- mapM (printSDoc PprForUser) warns
+ pprBagOfWarnings warns
+
+ -- get the module name
-- generate the interface file
case iface of
do run_something "Touching object file" ("touch " ++ o_file)
return False
- Just iface ->
-
- -- Deal with stubs
- let stub_h = basename ++ "_stub.h"
- let stub_c = basename ++ "_stub.c"
+ Just iface -> do
+ -- discover the filename for the .hi file in a roundabout way
+ let mod = md_id details
+ locn <- mkHomeModule mod basename input_fn
+ let hifile = hi_file locn
+ -- write out the interface file here...
+ return ()
- -- copy the .stub_h file into the current dir if necessary
- case maybe_stub_h of
- Nothing -> return ()
- Just tmp_stub_h -> do
- run_something "Copy stub .h file"
- ("cp " ++ tmp_stub_h ++ ' ':stub_h)
-
- -- #include <..._stub.h> in .hc file
- addCmdlineHCInclude tmp_stub_h -- hack
-
- -- copy the .stub_c file into the current dir, and compile it, if necessary
- case maybe_stub_c of
- Nothing -> return ()
- Just tmp_stub_c -> do -- copy the _stub.c file into the current dir
- run_something "Copy stub .c file"
- (unwords [
- "rm -f", stub_c, "&&",
- "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
- "cat", tmp_stub_c, ">> ", stub_c
- ])
-
- -- compile the _stub.c file w/ gcc
- pipeline <- genPipeline (StopBefore Ln) "" stub_c
- runPipeline pipeline stub_c False{-no linking-} False{-no -o option-}
-
- add ld_inputs (basename++"_stub.o")
+ -- deal with stubs
+ maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
+ case stub_o of
+ Nothing -> return ()
+ Just stub_o -> add ld_inputs stub_o
return True
+ }
-----------------------------------------------------------------------------
-- Cc phase
ASSERT(haskellish_file filename)
do pipeline <- genPipeline (StopBefore Hsc) ("preprocess") filename
runPipeline pipeline filename False{-no linking-} False{-no -o flag-}
+
+-----------------------------------------------------------------------------
+-- Compile a single module.
+--
+-- This is the interface between the compilation manager and the
+-- compiler proper (hsc), where we deal with tedious details like
+-- reading the OPTIONS pragma from the source file, and passing the
+-- output of hsc through the C compiler.
+
+-- The driver sits between 'compile' and 'hscMain', translating calls
+-- to the former into calls to the latter, and results from the latter
+-- into results from the former. It does things like preprocessing
+-- the .hs file if necessary, and compiling up the .stub_c files to
+-- generate Linkables.
+
+compile :: Finder -- to find modules
+ -> ModSummary -- summary, including source
+ -> Maybe ModIFace -- old interface, if available
+ -> HomeSymbolTable -- for home module ModDetails
+ -> PersistentCompilerState -- persistent compiler state
+ -> IO CompResult
+
+data CompResult
+ = CompOK ModDetails -- new details (HST additions)
+ (Maybe (ModIface, Linkable))
+ -- summary and code; Nothing => compilation not reqd
+ -- (old summary and code are still valid)
+ PersistentCompilerState -- updated PCS
+ (Bag WarnMsg) -- warnings
+
+ | CompErrs PersistentCompilerState -- updated PCS
+ (Bag ErrMsg) -- errors
+ (Bag WarnMsg) -- warnings
+
+
+compile finder summary old_iface hst pcs = do
+ verb <- readIORef verbose
+ when verb (hPutStrLn stderr ("compile: compiling " ++
+ name_of_summary summary))
+
+ init_dyn_flags <- readIORef v_InitDynFlags
+ writeIORef v_DynFlags init_dyn_flags
+
+ let input_fn = case ms_ppsource summary of
+ Just (ppsource, fingerprint) -> ppsource
+ Nothing -> hs_file (ms_location summary)
+
+ when verb (hPutStrLn stderr ("compile: input file " ++ input_fn))
+
+ opts <- getOptionsFromSource input_fn
+ processArgs dynamic_flags opts []
+ dyn_flags <- readIORef v_DynFlags
+
+ output_fn <- case hsc_lang of
+ HscAsm -> newTempName (phaseInputExt As)
+ HscC -> newTempName (phaseInputExt HCc)
+ HscJava -> newTempName "java" -- ToDo
+ HscInterpreter -> return (error "no output file")
+
+ -- run the compiler
+ hsc_result <- hscMain dyn_flags summary old_iface output_fn hst pcs
+
+ case hsc_result of {
+ HscErrs pcs errs warns -> return (CompErrs pcs errs warns);
+
+ HscOK details maybe_iface
+ maybe_stub_h maybe_stub_c maybe_interpreted_code pcs warns -> do
+
+ -- if no compilation happened, bail out early
+ case maybe_iface of {
+ Nothing -> return (CompOK details Nothing pcs warns);
+ Just iface -> do
+
+ let (basename, _) = splitFilename (hs_file (ms_location summary))
+ maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
+ stub_unlinked <- case maybe_stub_o of
+ Nothing -> []
+ Just stub_o -> [ DotO stub_o ]
+
+ hs_unlinked <-
+ case hsc_lang of
+
+ -- in interpreted mode, just return the compiled code
+ -- as our "unlinked" object.
+ HscInterpreter ->
+ case maybe_interpreted_code of
+ Just code -> return (Trees code)
+ Nothing -> panic "compile: no interpreted code"
+
+ -- we're in batch mode: finish the compilation pipeline.
+ _other -> do pipe <- genPipeline (StopBefore Ln) "" output_fn
+ o_file <- runPipeline pipe output_fn False False
+ return [ DotO o_file ]
+
+ let linkable = LM (moduleName (ms_mod summary))
+ (hs_unlinked ++ stub_unlinked)
+
+ return (CompOK details (Just (iface, linkable)) pcs warns)
+ }
+ }
+
+-----------------------------------------------------------------------------
+-- stub .h and .c files (for foreign export support)
+
+dealWithStubs basename maybe_stub_h maybe_stub_c
+
+ = do let stub_h = basename ++ "_stub.h"
+ let stub_c = basename ++ "_stub.c"
+
+ -- copy the .stub_h file into the current dir if necessary
+ case maybe_stub_h of
+ Nothing -> return ()
+ Just tmp_stub_h -> do
+ run_something "Copy stub .h file"
+ ("cp " ++ tmp_stub_h ++ ' ':stub_h)
+
+ -- #include <..._stub.h> in .hc file
+ addCmdlineHCInclude tmp_stub_h -- hack
+
+ -- copy the .stub_c file into the current dir, and compile it, if necessary
+ case maybe_stub_c of
+ Nothing -> return Nothing
+ Just tmp_stub_c -> do -- copy the _stub.c file into the current dir
+ run_something "Copy stub .c file"
+ (unwords [
+ "rm -f", stub_c, "&&",
+ "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
+ "cat", tmp_stub_c, ">> ", stub_c
+ ])
+
+ -- compile the _stub.c file w/ gcc
+ pipeline <- genPipeline (StopBefore Ln) "" stub_c
+ stub_o <- runPipeline pipeline stub_c False{-no linking-}
+ False{-no -o option-}
+
+ return (Just stub_o)
projects / ghc-hetmet.git / blobdiff