Commit 11447047 authored by sof's avatar sof

[project @ 2001-10-26 00:53:27 by sof]

Added support for a custom pre-processor pass:

  ghc -F -pgmF/path/to/a/pre/processor ...

will now run /path/to/a/pre/processor over Haskell
input sources. It is positioned in the compilation
pipeline just before the compiler proper, but after
unlit'ing and CPP'ing. The pre-processor is passed
the following command-line when invoked:

   /path/to/a/pre/processor orig_input_source_file_path
   			    input_source_file
			    output_source_file
			    <other options>

Additionally options can be fed directly to the
pre-processor via -optF<option> options.

The -F option causes the pre-processor to run _iff_ one
has been specified via -pgmF (there's some redundancy
here, but I went for this cmd-line interface as it's
consistent with the general -pgm<Foo> story).

Motivation:

 * hooking in a pre-processor is occasionally useful;
   e.g., cheap&cheerful way to integrate language
   extensions with GHC, compile-time syntax/style
   checking etc.

 * Artfully re-using the CPP phase (by specifying your
   own via -pgmP) doesn't really work as the driver
   really assumes that GNU cpp is what's being invoked
   (and path mangling is also performed on Win32 platforms).

   Additionally, there are cases when you want to be
   able to run CPP _and_ a pre-processor.

 * The alternative of running the pre-processor as a
   separate program in a Makefile (say) doesn't work
   in interpreted mode, and this approach also forces
   you to give up on recompilation checking when in
   batch mode.
parent 32e87ecf
......@@ -293,12 +293,14 @@ data DynFlags = DynFlags {
extCoreName :: String, -- name of the .core output file
verbosity :: Int, -- verbosity level
cppFlag :: Bool, -- preprocess with cpp?
ppFlag :: Bool, -- preprocess with a Haskell Pp?
stolen_x86_regs :: Int,
cmdlineHcIncludes :: [String], -- -#includes
-- options for particular phases
opt_L :: [String],
opt_P :: [String],
opt_F :: [String],
opt_c :: [String],
opt_a :: [String],
opt_m :: [String],
......@@ -328,10 +330,12 @@ defaultDynFlags = DynFlags {
extCoreName = "",
verbosity = 0,
cppFlag = False,
ppFlag = False,
stolen_x86_regs = 4,
cmdlineHcIncludes = [],
opt_L = [],
opt_P = [],
opt_F = [],
opt_c = [],
opt_a = [],
opt_m = [],
......
{-# OPTIONS -#include "hschooks.h" #-}
-----------------------------------------------------------------------------
-- $Id: DriverFlags.hs,v 1.76 2001/10/17 15:44:40 simonpj Exp $
-- $Id: DriverFlags.hs,v 1.77 2001/10/26 00:53:27 sof Exp $
--
-- Driver flags
--
......@@ -300,12 +300,14 @@ static_flags =
dynamic_flags = [
( "cpp", NoArg (updDynFlags (\s -> s{ cppFlag = True })) )
, ( "F", NoArg (updDynFlags (\s -> s{ ppFlag = True })) )
, ( "#include", HasArg (addCmdlineHCInclude) )
, ( "v", OptPrefix (setVerbosity) )
, ( "optL", HasArg (addOpt_L) )
, ( "optP", HasArg (addOpt_P) )
, ( "optF", HasArg (addOpt_F) )
, ( "optc", HasArg (addOpt_c) )
, ( "optm", HasArg (addOpt_m) )
, ( "opta", HasArg (addOpt_a) )
......@@ -541,6 +543,7 @@ machdepCCOpts
addOpt_L a = updDynFlags (\s -> s{opt_L = a : opt_L s})
addOpt_P a = updDynFlags (\s -> s{opt_P = a : opt_P s})
addOpt_F a = updDynFlags (\s -> s{opt_F = a : opt_F s})
addOpt_c a = updDynFlags (\s -> s{opt_c = a : opt_c s})
addOpt_a a = updDynFlags (\s -> s{opt_a = a : opt_a s})
addOpt_m a = updDynFlags (\s -> s{opt_m = a : opt_m s})
......
-----------------------------------------------------------------------------
-- $Id: DriverPhases.hs,v 1.12 2001/08/15 09:32:40 rrt Exp $
-- $Id: DriverPhases.hs,v 1.13 2001/10/26 00:53:27 sof Exp $
--
-- GHC Driver
--
......@@ -41,6 +41,7 @@ data Phase
= MkDependHS -- haskell dependency generation
| Unlit
| Cpp
| HsPp
| Hsc -- ToDo: HscTargetLang
| Cc
| HCc -- Haskellised C (as opposed to vanilla C) compilation
......@@ -59,6 +60,7 @@ data Phase
-- by its suffix.
startPhase "lhs" = Unlit
startPhase "hs" = Cpp
startPhase "hscpp" = HsPp
startPhase "hspp" = Hsc
startPhase "hc" = HCc
startPhase "c" = Cc
......@@ -72,6 +74,7 @@ startPhase _ = Ln -- all unknown file types
-- the input requirements of the next phase.
phaseInputExt Unlit = "lhs"
phaseInputExt Cpp = "lpp" -- intermediate only
phaseInputExt HsPp = "hscpp"
phaseInputExt Hsc = "hspp"
phaseInputExt HCc = "hc"
phaseInputExt Cc = "c"
......@@ -86,8 +89,8 @@ phaseInputExt Ilx2Il = "ilx"
phaseInputExt Ilasm = "il"
#endif
haskellish_suffix = (`elem` [ "hs", "hspp", "lhs", "hc", "raw_s" ])
haskellish_src_suffix = (`elem` [ "hs", "hspp", "lhs" ])
haskellish_suffix = (`elem` [ "hs", "hspp", "hscpp", "lhs", "hc", "raw_s" ])
haskellish_src_suffix = (`elem` [ "hs", "hspp", "hscpp", "lhs" ])
cish_suffix = (`elem` [ "c", "s", "S" ]) -- maybe .cc et al.??
#if mingw32_TARGET_OS || cygwin32_TARGET_OS
......
......@@ -159,26 +159,26 @@ genPipeline todo stop_flag persistent_output lang (filename,suffix)
let
----------- ----- ---- --- -- -- - - -
pipeline
| todo == DoMkDependHS = [ Unlit, Cpp, MkDependHS ]
| todo == DoMkDependHS = [ Unlit, Cpp, HsPp, MkDependHS ]
| haskellish =
case real_lang of
HscC | split && mangle -> [ Unlit, Cpp, Hsc, HCc, Mangle,
HscC | split && mangle -> [ Unlit, Cpp, HsPp, Hsc, HCc, Mangle,
SplitMangle, SplitAs ]
| mangle -> [ Unlit, Cpp, Hsc, HCc, Mangle, As ]
| mangle -> [ Unlit, Cpp, HsPp, Hsc, HCc, Mangle, As ]
| split -> not_valid
| otherwise -> [ Unlit, Cpp, Hsc, HCc, As ]
| otherwise -> [ Unlit, Cpp, HsPp, Hsc, HCc, As ]
HscAsm | split -> [ Unlit, Cpp, Hsc, SplitMangle, SplitAs ]
| otherwise -> [ Unlit, Cpp, Hsc, As ]
HscAsm | split -> [ Unlit, Cpp, HsPp, Hsc, SplitMangle, SplitAs ]
| otherwise -> [ Unlit, Cpp, HsPp, Hsc, As ]
HscJava | split -> not_valid
| otherwise -> error "not implemented: compiling via Java"
#ifdef ILX
HscILX | split -> not_valid
| otherwise -> [ Unlit, Cpp, Hsc, Ilx2Il, Ilasm ]
| otherwise -> [ Unlit, Cpp, HsPp, Hsc, Ilx2Il, Ilasm ]
#endif
HscNothing -> [ Unlit, Cpp, Hsc ]
HscNothing -> [ Unlit, Cpp, HsPp, Hsc ]
| cish = [ Cc, As ]
......@@ -198,22 +198,18 @@ genPipeline todo stop_flag persistent_output lang (filename,suffix)
----------- ----- ---- --- -- -- - - -
-- this shouldn't happen.
if start_phase /= Ln && start_phase `notElem` pipeline
then throwDyn (CmdLineError ("can't find starting phase for "
++ filename))
else do
when (start_phase /= Ln && start_phase `notElem` pipeline)
(throwDyn (CmdLineError ("can't find starting phase for "
++ filename)))
-- if we can't find the phase we're supposed to stop before,
-- something has gone wrong. This test carefully avoids the
-- case where we aren't supposed to do any compilation, because the file
-- is already in linkable form (for example).
if start_phase `elem` pipeline &&
(stop_phase /= Ln && stop_phase `notElem` pipeline)
then throwDyn (UsageError
("flag " ++ stop_flag
++ " is incompatible with source file `" ++ filename ++ "'"))
else do
when (start_phase `elem` pipeline &&
(stop_phase /= Ln && stop_phase `notElem` pipeline))
(throwDyn (UsageError
("flag " ++ stop_flag
++ " is incompatible with source file `" ++ filename ++ "'")))
let
-- .o and .hc suffixes can be overriden by command-line options:
myPhaseInputExt Ln | Just s <- osuf = s
......@@ -279,7 +275,8 @@ pipeLoop (all_phases@((phase, keep, o_suffix):phases))
output_fn <- outputFileName (null phases) keep o_suffix
mbCarryOn <- run_phase phase orig_basename orig_suffix input_fn output_fn
mbCarryOn <- 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.
case mbCarryOn of
......@@ -388,48 +385,71 @@ run_phase Cpp basename suff input_fn output_fn
])
return (Just output_fn)
-------------------------------------------------------------------------------
-- HsPp phase
run_phase HsPp basename suff input_fn output_fn
= do src_opts <- getOptionsFromSource input_fn
unhandled_flags <- processArgs dynamic_flags src_opts []
checkProcessArgsResult unhandled_flags basename suff
let orig_fn = basename ++ '.':suff
do_pp <- dynFlag ppFlag
if not do_pp then
-- no need to preprocess, just pass input file along
-- to the next phase of the pipeline.
return (Just input_fn)
else do
hspp_opts <- getOpts opt_F
hs_src_pp_opts <- readIORef v_Hs_source_pp_opts
SysTools.runPp ( [ SysTools.Option orig_fn
, SysTools.Option input_fn
, SysTools.FileOption "" output_fn
] ++
map SysTools.Option hs_src_pp_opts ++
map SysTools.Option hspp_opts
)
return (Just output_fn)
-----------------------------------------------------------------------------
-- MkDependHS phase
run_phase MkDependHS basename suff input_fn output_fn = do
src <- readFile input_fn
let (import_sources, import_normals, _) = getImports src
let orig_fn = basename ++ '.':suff
deps_sources <- mapM (findDependency True orig_fn) import_sources
deps_normals <- mapM (findDependency False orig_fn) import_normals
let deps = deps_sources ++ deps_normals
osuf_opt <- readIORef v_Object_suf
let osuf = case osuf_opt of
Nothing -> phaseInputExt Ln
Just s -> s
extra_suffixes <- readIORef v_Dep_suffixes
let suffixes = osuf : map (++ ('_':osuf)) extra_suffixes
ofiles = map (\suf -> basename ++ '.':suf) suffixes
objs <- mapM odir_ify ofiles
run_phase MkDependHS basename suff input_fn output_fn
= do src <- readFile input_fn
let (import_sources, import_normals, _) = getImports src
let orig_fn = basename ++ '.':suff
deps_sources <- mapM (findDependency True orig_fn) import_sources
deps_normals <- mapM (findDependency False orig_fn) import_normals
let deps = deps_sources ++ deps_normals
osuf_opt <- readIORef v_Object_suf
let osuf = case osuf_opt of
Nothing -> phaseInputExt Ln
Just s -> s
extra_suffixes <- readIORef v_Dep_suffixes
let suffixes = osuf : map (++ ('_':osuf)) extra_suffixes
ofiles = map (\suf -> basename ++ '.':suf) suffixes
objs <- mapM odir_ify ofiles
-- Handle for file that accumulates dependencies
hdl <- readIORef v_Dep_tmp_hdl
hdl <- readIORef v_Dep_tmp_hdl
-- std dependency 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 v_Hi_suf
let dep_base = remove_suffix '.' dep
deps = (dep_base ++ hisuf)
: map (\suf -> dep_base ++ suf ++ '_':hisuf) extra_suffixes
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 v_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 ]
sequence_ (zipWith (\o d -> hPutStrLn hdl (o ++ " : " ++ d)) objs deps)
return (Just output_fn)
sequence_ (map genDep [ d | Just d <- deps ])
return (Just output_fn)
-- add the lines to dep_makefile:
-- always:
......@@ -965,9 +985,10 @@ preprocess :: FilePath -> IO FilePath
preprocess filename =
ASSERT(haskellish_src_file filename)
do restoreDynFlags -- Restore to state of last save
let fInfo = (filename, getFileSuffix filename)
pipeline <- genPipeline (StopBefore Hsc) ("preprocess") False
defaultHscLang (filename, getFileSuffix filename)
(fn,_) <- runPipeline pipeline (filename,getFileSuffix filename)
defaultHscLang fInfo
(fn,_) <- runPipeline pipeline fInfo
False{-no linking-} False{-no -o flag-}
return fn
......
-----------------------------------------------------------------------------
-- $Id: DriverState.hs,v 1.60 2001/10/22 10:33:50 simonmar Exp $
-- $Id: DriverState.hs,v 1.61 2001/10/26 00:53:27 sof Exp $
--
-- Settings for the driver
--
......@@ -64,6 +64,7 @@ v_Hs_source_cpp_opts = global
]
{-# NOINLINE v_Hs_source_cpp_opts #-}
-- Keep output from intermediate phases
GLOBAL_VAR(v_Keep_hi_diffs, False, Bool)
GLOBAL_VAR(v_Keep_hc_files, False, Bool)
......@@ -82,6 +83,9 @@ GLOBAL_VAR(v_Do_asm_mangling, True, Bool)
GLOBAL_VAR(v_Excess_precision, False, Bool)
GLOBAL_VAR(v_Read_DotGHCi, True, Bool)
-- Preprocessor flags
GLOBAL_VAR(v_Hs_source_pp_opts, [], [String])
-----------------------------------------------------------------------------
-- Splitting object files (for libraries)
......
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
-----------------------------------------------------------------------------
-- $Id: Main.hs,v 1.89 2001/10/25 02:13:13 sof Exp $
-- $Id: Main.hs,v 1.90 2001/10/26 00:53:27 sof Exp $
--
-- GHC Driver program
--
......@@ -43,7 +43,7 @@ import DriverFlags ( dynFlag, buildStaticHscOpts, dynamic_flags,
processArgs, static_flags)
import DriverMkDepend ( beginMkDependHS, endMkDependHS )
import DriverPhases ( Phase(Hsc, HCc), haskellish_src_file, objish_file )
import DriverPhases ( Phase(HsPp, Hsc, HCc), haskellish_src_file, objish_file )
import DriverUtil ( add, handle, handleDyn, later, splitFilename,
unknownFlagErr, getFileSuffix )
......@@ -286,11 +286,12 @@ main =
-- just preprocess (Haskell source only)
let src_and_suff = (src, getFileSuffix src)
pp <- if not (haskellish_src_file src) || mode == StopBefore Hsc
let not_hs_file = not (haskellish_src_file src)
pp <- if not_hs_file || mode == StopBefore Hsc || mode == StopBefore HsPp
then return src_and_suff else do
phases <- genPipeline (StopBefore Hsc) stop_flag
False{-not persistent-} defaultHscLang
src_and_suff
False{-not persistent-} defaultHscLang
src_and_suff
pipeLoop phases src_and_suff False{-no linking-} False{-no -o flag-}
basename suffix
......
......@@ -19,6 +19,7 @@ module SysTools (
-- Interface to system tools
runUnlit, runCpp, runCc, -- [Option] -> IO ()
runPp, -- [Option] -> IO ()
runMangle, runSplit, -- [Option] -> IO ()
runAs, runLink, -- [Option] -> IO ()
runMkDLL,
......@@ -182,6 +183,7 @@ All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
\begin{code}
GLOBAL_VAR(v_Pgm_L, error "pgm_L", String) -- unlit
GLOBAL_VAR(v_Pgm_P, error "pgm_P", String) -- cpp
GLOBAL_VAR(v_Pgm_F, error "pgm_F", String) -- pp
GLOBAL_VAR(v_Pgm_c, error "pgm_c", String) -- gcc
GLOBAL_VAR(v_Pgm_m, error "pgm_m", String) -- asm code mangler
GLOBAL_VAR(v_Pgm_s, error "pgm_s", String) -- asm code splitter
......@@ -385,6 +387,7 @@ initSysTools minusB_args
; writeIORef v_Pgm_L unlit_path
; writeIORef v_Pgm_P cpp_path
; writeIORef v_Pgm_F ""
; writeIORef v_Pgm_c gcc_path
; writeIORef v_Pgm_m mangle_path
; writeIORef v_Pgm_s split_path
......@@ -416,6 +419,7 @@ setPgm :: String -> IO ()
-- So the first character says which program to override
setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
setPgm ('F' : pgm) = writeIORef v_Pgm_F pgm
setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
......@@ -514,7 +518,7 @@ showOptions ls = unwords (map (quote.showOpt) ls)
%************************************************************************
%* *
\subsection{Running an external program}
n%* *
%* *
%************************************************************************
......@@ -527,6 +531,10 @@ runCpp :: [Option] -> IO ()
runCpp args = do p <- readIORef v_Pgm_P
runSomething "C pre-processor" p args
runPp :: [Option] -> IO ()
runPp args = do p <- readIORef v_Pgm_F
runSomething "Haskell pre-processor" p args
runCc :: [Option] -> IO ()
runCc args = do p <- readIORef v_Pgm_c
runSomething "C Compiler" p args
......@@ -781,7 +789,7 @@ dosifyPath stuff
cygdrive_prefix = "/cygdrive/"
real_stuff
| cygdrive_prefix `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
| cygdrive_prefix `isPrefixOf` stuff = dropList cygdrive_prefix stuff
| otherwise = stuff
#else
......@@ -832,7 +840,7 @@ getExecDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
if ret == 0 then destructArray len buf >> return Nothing
else do s <- peekCString buf
destructArray len buf
return (Just (reverse (drop (length "/bin/ghc.exe") (reverse (unDosifyPath s)))))
return (Just (reverse (dropList "/bin/ghc.exe" (reverse (unDosifyPath s)))))
foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int -> IO Int32
......
Markdown is supported
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