-----------------------------------------------------------------------------
-- ToDo:
--- test:
--- stub files
-
-- time commands when run with -v
-- split marker
-- mkDLL
exitWith ExitSuccess
long_usage = do
- let usage_dir = findFile "ghc-usage.txt" (_GHC_DRIVER_DIR++"/ghc-usage.txt")
+ let usage_dir = findFile "ghc-usage.txt" (cGHC_DRIVER_DIR++"/ghc-usage.txt")
usage <- readFile (usage_dir++"/ghc-usage.txt")
dump usage
exitWith ExitSuccess
dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s
dump (c:s) = hPutChar stderr c >> dump s
+version_str = cProjectVersion ++
+ ( if cProjectPatchLevel /= "0" && cProjectPatchLevel /= ""
+ then '.':cProjectPatchLevel
+ else "")
+
-----------------------------------------------------------------------------
-- Phases
| 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,Ord,Enum,Ix,Show,Bounded)
GLOBAL_VAR(cpp_flag, False, Bool)
hs_source_cpp_opts = global
[ "-D__HASKELL1__="++_Haskell1Version
- , "-D__GLASGOW_HASKELL__="++_ProjectVersionInt
+ , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
, "-D__HASKELL98__"
, "-D__CONCURRENT_HASKELL__"
]
-- Misc
GLOBAL_VAR(dry_run, False, Bool)
GLOBAL_VAR(recomp, True, Bool)
-GLOBAL_VAR(tmp_prefix, _TMPDIR, String)
+GLOBAL_VAR(tmp_prefix, cTMPDIR, String)
GLOBAL_VAR(stolen_x86_regs, 4, Int)
GLOBAL_VAR(static, True, Bool) -- ToDo: not for mingw32
GLOBAL_VAR(collect_ghc_timing, False, Bool)
GLOBAL_VAR(n_split_files, 0, Int)
can_split :: Bool
-can_split = prefixMatch "i386" _TARGETPLATFORM
- || prefixMatch "alpha" _TARGETPLATFORM
- || prefixMatch "hppa" _TARGETPLATFORM
- || prefixMatch "m68k" _TARGETPLATFORM
- || prefixMatch "mips" _TARGETPLATFORM
- || prefixMatch "powerpc" _TARGETPLATFORM
- || prefixMatch "rs6000" _TARGETPLATFORM
- || prefixMatch "sparc" _TARGETPLATFORM
+can_split = prefixMatch "i386" cTARGETPLATFORM
+ || prefixMatch "alpha" cTARGETPLATFORM
+ || prefixMatch "hppa" cTARGETPLATFORM
+ || prefixMatch "m68k" cTARGETPLATFORM
+ || prefixMatch "mips" cTARGETPLATFORM
+ || prefixMatch "powerpc" cTARGETPLATFORM
+ || prefixMatch "rs6000" cTARGETPLATFORM
+ || prefixMatch "sparc" cTARGETPLATFORM
-----------------------------------------------------------------------------
-- Compiler output options
| HscAsm
| HscJava
-GLOBAL_VAR(hsc_lang, if _GhcWithNativeCodeGen == "YES" &&
- prefixMatch "i386" _TARGETPLATFORM
+GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" &&
+ prefixMatch "i386" cTARGETPLATFORM
then HscAsm
else HscC,
HscLang)
odir_opt <- readIORef output_dir
case odir_opt of
Nothing -> return f
- Just d -> return (newdir f d)
+ Just d -> return (newdir d f)
osuf_ify :: String -> IO String
osuf_ify f = do
osuf_opt <- readIORef output_suf
case osuf_opt of
Nothing -> return f
- Just s -> return (newsuf f s)
+ Just s -> return (newsuf s f)
-----------------------------------------------------------------------------
-- Hi Files
-----------------------------------------------------------------------------
-- Programs for particular phases
-GLOBAL_VAR(pgm_dep, findFile "mkdependHS" _GHC_MKDEPENDHS, String)
-GLOBAL_VAR(pgm_L, findFile "unlit" _GHC_UNLIT, String)
-GLOBAL_VAR(pgm_P, findFile "hscpp" _GHC_HSCPP, String)
-GLOBAL_VAR(pgm_C, findFile "hsc" _GHC_HSC, String)
-GLOBAL_VAR(pgm_c, _GCC, String)
-GLOBAL_VAR(pgm_m, findFile "ghc-asm" _GHC_MANGLER, String)
-GLOBAL_VAR(pgm_s, findFile "ghc-split" _GHC_SPLIT, String)
-GLOBAL_VAR(pgm_a, _GCC, String)
-GLOBAL_VAR(pgm_l, _GCC, String)
+GLOBAL_VAR(pgm_dep, findFile "mkdependHS" cGHC_MKDEPENDHS, String)
+GLOBAL_VAR(pgm_L, findFile "unlit" cGHC_UNLIT, String)
+GLOBAL_VAR(pgm_P, cRAWCPP, String)
+GLOBAL_VAR(pgm_C, findFile "hsc" cGHC_HSC, String)
+GLOBAL_VAR(pgm_c, cGCC, String)
+GLOBAL_VAR(pgm_m, findFile "ghc-asm" cGHC_MANGLER, String)
+GLOBAL_VAR(pgm_s, findFile "ghc-split" cGHC_SPLIT, String)
+GLOBAL_VAR(pgm_a, cGCC, String)
+GLOBAL_VAR(pgm_l, cGCC, String)
-----------------------------------------------------------------------------
-- Options for particular phases
-- )
machdepCCOpts
- | prefixMatch "alpha" _TARGETPLATFORM
+ | prefixMatch "alpha" cTARGETPLATFORM
= return ( ["-static"], [] )
- | prefixMatch "hppa" _TARGETPLATFORM
+ | prefixMatch "hppa" cTARGETPLATFORM
-- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
-- (very nice, but too bad the HP /usr/include files don't agree.)
= return ( ["-static", "-D_HPUX_SOURCE"], [] )
- | prefixMatch "m68k" _TARGETPLATFORM
+ | prefixMatch "m68k" cTARGETPLATFORM
-- -fno-defer-pop : for the .hc files, we want all the pushing/
-- popping of args to routines to be explicit; if we let things
-- be deferred 'til after an STGJUMP, imminent death is certain!
-- as on iX86, where we *do* steal the frame pointer [%ebp].)
= return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
- | prefixMatch "i386" _TARGETPLATFORM
+ | prefixMatch "i386" cTARGETPLATFORM
-- -fno-defer-pop : basically the same game as for m68k
--
-- -fomit-frame-pointer : *must* in .hc files; because we're stealing
"-DSTOLEN_X86_REGS="++show n_regs ]
)
- | prefixMatch "mips" _TARGETPLATFORM
+ | prefixMatch "mips" cTARGETPLATFORM
= return ( ["static"], [] )
- | prefixMatch "powerpc" _TARGETPLATFORM || prefixMatch "rs6000" _TARGETPLATFORM
+ | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
= return ( ["static"], ["-finhibit-size-directive"] )
| otherwise
-- let-no-escape always on for now
verb <- is_verbose
- let hi_vers = "-fhi-version="++_ProjectVersionInt
+ let hi_vers = "-fhi-version="++cProjectVersionInt
static <- (do s <- readIORef static; if s then return "-static" else return "")
l <- readIORef hsc_lang
l <- hGetLine h
case () of
() | null l -> look h
+ | prefixMatch "#" l -> look h
| prefixMatch "{-# LINE" l -> look h
| Just (opts:_) <- matchRegex optionRegex l
-> return (words opts)
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])
argv' <- setTopDir argv
-- read the package configuration
- let conf = findFile "package.conf" (_GHC_DRIVER_DIR++"/package.conf.inplace")
+ let conf = findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")
contents <- readFile conf
writeIORef package_details (read contents)
compileFile (phase, src) = do
let (orig_base, _) = split_filename src
if phase < Ln -- anything to do?
- then run_pipeline stop_phase do_linking orig_base (phase,src)
+ then run_pipeline stop_phase do_linking True orig_base (phase,src)
else return src
o_files <- mapM compileFile phase_srcs
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 orig_basename (phase, input_fn) = do
+run_pipeline last_phase do_linking use_ofile orig_basename (phase, input_fn)
+ | phase > last_phase = return input_fn
+ | otherwise
+ = do
let (basename,ext) = split_filename input_fn
- split <- readIORef split_object_files
+ split <- readIORef split_object_files
mangle <- readIORef do_asm_mangling
- lang <- readIORef hsc_lang
+ lang <- readIORef hsc_lang
-- 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.
+ -- optional, and splitting involves one extra phase and an alternate
+ -- assembler.
let next_phase =
case phase of
Hsc -> case lang of
Cc -> As
Mangle | not split -> As
-
+ SplitMangle -> SplitAs
+ SplitAs -> Ln
+
_ -> succ phase
- -- filename extension for the output
+ -- filename extension for the output, determined by next_phase
let new_ext = phase_input_ext next_phase
-- Figure out what the output from this pass should be called.
_other -> False
output_fn <-
- (if phase == last_phase && not do_linking
+ (if phase == last_phase && not do_linking && use_ofile
then do o_file <- readIORef output_file
case o_file of
Just s -> return s
osuf_ify f
-- .o files are always kept. .s files and .hc file may be kept.
- else if keep_this_output
+ else if keep_this_output
then odir_ify (orig_basename ++ '.':new_ext)
else do filename <- newTempName new_ext
add files_to_clean filename
run_phase phase orig_basename input_fn output_fn
- if (phase == last_phase)
- then return output_fn
- else run_pipeline last_phase do_linking
- orig_basename (next_phase, output_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.
+ if (next_phase > last_phase && last_phase == Cpp)
+ then run_something "Dump pre-processed file to stdout"
+ ("cat " ++ output_fn)
+ else return ()
+
+ run_pipeline last_phase do_linking use_ofile
+ orig_basename (next_phase, output_fn)
-- find a temporary name that doesn't already exist.
do_mkdependHS :: [String] -> [String] -> IO ()
do_mkdependHS cmd_opts srcs = do
- -- ToDo: push (@MkDependHS_flags, "-o$Osuffix") if $Osuffix;
+
-- # They're not (currently) needed, but we need to quote any -#include options
-- foreach (@Cmd_opts) {
-- s/-#include.*$/'$&'/g;
= do unlit <- readIORef pgm_L
unlit_flags <- getOpts opt_L
run_something "Literate pre-processor"
- ("echo '{-# LINE 1 \"" ++input_fn++"\" -}' > "++output_fn++" && "
+ ("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
-------------------------------------------------------------------------------
--- HsCpp phase
+-- Cpp phase
run_phase Cpp basename input_fn output_fn
= do src_opts <- getOptionsFromSource input_fn
++ include_paths
++ hs_src_cpp_opts
++ hscpp_opts
- ++ [ input_fn, ">>", output_fn ]
+ ++ [ "-x", "c", input_fn, ">>", output_fn ]
))
else do
run_something "Inefective C pre-processor"
-- Generate -Rghc-timing info
on (timing) (
run_something "Generate timing stats"
- (findFile "ghc-stats" _GHC_STATS ++ ' ':stat_file)
+ (findFile "ghc-stats" cGHC_STATS ++ ' ':stat_file)
)
-- Deal with stubs
])
-- compile the _stub.c file w/ gcc
- run_pipeline As False (basename++"_stub") (Cc, stub_c)
+ run_pipeline As False{-no linking-}
+ False{-no -o option-}
+ (basename++"_stub")
+ (Cc, stub_c)
+
add ld_inputs (basename++"_stub.o")
)
then md_regd_c_flags
else [])
++ [ verb, "-S", "-Wimplicit", opt_flag ]
- ++ [ "-D__GLASGOW_HASKELL__="++_ProjectVersionInt ]
+ ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
++ cc_opts
++ include_paths
++ pkg_extra_cc_opts
= do mangler <- readIORef pgm_m
mangler_opts <- getOpts opt_m
machdep_opts <-
- if (prefixMatch "i386" _TARGETPLATFORM)
+ if (prefixMatch "i386" cTARGETPLATFORM)
then do n_regs <- readIORef stolen_x86_regs
return [ show n_regs ]
else return []
-- As phase
run_phase As basename input_fn output_fn
- = do split <- readIORef split_object_files
- as <- readIORef pgm_a
+ = do as <- readIORef pgm_a
+ as_opts <- getOpts opt_a
+
+ cmdline_include_paths <- readIORef include_paths
+ let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
+ run_something "Assembler"
+ (unwords (as : as_opts
+ ++ cmdline_include_flags
+ ++ [ "-c", input_fn, "-o", output_fn ]
+ ))
+
+run_phase SplitAs basename input_fn output_fn
+ = do as <- readIORef pgm_a
as_opts <- getOpts opt_a
- if not split then do
- cmdline_include_paths <- readIORef include_paths
- let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
- run_something "Assembler"
- (unwords (as : as_opts
- ++ cmdline_include_flags
- ++ [ "-c", input_fn, "-o", output_fn ]
- ))
-
- else do
- odir_opt <- readIORef output_dir
- let odir | Just s <- odir_opt = s
- | otherwise = basename
-
- split_s_prefix <- readIORef split_prefix
- n <- readIORef n_split_files
-
- odir <- readIORef output_dir
- let real_odir = case odir of
+ odir_opt <- readIORef output_dir
+ let odir | Just s <- odir_opt = s
+ | otherwise = basename
+
+ split_s_prefix <- readIORef split_prefix
+ n <- readIORef n_split_files
+
+ odir <- readIORef output_dir
+ let real_odir = case odir of
Nothing -> basename
Just d -> d
-
- let assemble_file n = do
+
+ let assemble_file n = do
let input_s = split_s_prefix ++ "__" ++ show n ++ ".s"
- let output_o = newdir real_odir
+ let output_o = newdir real_odir
(basename ++ "__" ++ show n ++ ".o")
- run_something "Assembler"
- (unwords (as : as_opts
- ++ [ "-c", "-o ", output_o, input_s ]
- ))
-
- mapM_ assemble_file [1..n]
+ real_o <- osuf_ify output_o
+ run_something "Assembler"
+ (unwords (as : as_opts
+ ++ [ "-c", "-o", real_o, input_s ]
+ ))
+
+ mapM_ assemble_file [1..n]
-----------------------------------------------------------------------------
-- Linking
-- probably _stub.o files
extra_ld_inputs <- readIORef ld_inputs
+ -- opts from -optl-<blah>
+ extra_ld_opts <- getOpts opt_l
+
run_something "Linker"
(unwords
([ ln, verb, "-o", output_fn ]
- -- ToDo: -u <blah> options
++ o_files
++ unknown_srcs
++ extra_ld_inputs
++ pkg_lib_path_opts
++ pkg_lib_opts
++ pkg_extra_ld_opts
+ ++ extra_ld_opts
)
)
| AnySuffix (String -> IO ()) -- flag is a prefix, pass whole arg to fn
| PassFlag (String -> IO ()) -- flag with no arg, pass flag to fn
+-- note that ordering is important in the following list: any flag which
+-- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
+-- flags further down the list with the same prefix.
+
opts =
[ ------- help -------------------------------------------------------
( "?" , NoArg long_usage)
------- version ----------------------------------------------------
- , ( "-version" , NoArg (do hPutStrLn stderr (_ProjectName
- ++ ", version " ++ _ProjectVersion
- ++ ", patchlevel " ++ _ProjectPatchLevel)
- exitWith ExitSuccess))
+ , ( "-version" , NoArg (do hPutStrLn stderr (cProjectName
+ ++ ", version " ++ version_str)
+ exitWith ExitSuccess))
+ , ( "-numeric-version", NoArg (do hPutStrLn stderr version_str
+ exitWith ExitSuccess))
------- verbosity ----------------------------------------------------
, ( "v" , NoArg (writeIORef verbose True) )
, ( "no-recomp" , NoArg (writeIORef recomp False) )
------- ways --------------------------------------------------------
- , ( "prof" , NoArg (add ways WayProf) )
- , ( "unreg" , NoArg (add ways WayUnreg) )
- , ( "ticky" , NoArg (add ways WayTicky) )
- , ( "parallel" , NoArg (add ways WayPar) )
- , ( "gransim" , NoArg (add ways WayGran) )
- , ( "smp" , NoArg (add ways WaySMP) )
- , ( "debug" , NoArg (add ways WayDebug) )
+ , ( "prof" , NoArg (addNoDups ways WayProf) )
+ , ( "unreg" , NoArg (addNoDups ways WayUnreg) )
+ , ( "ticky" , NoArg (addNoDups ways WayTicky) )
+ , ( "parallel" , NoArg (addNoDups ways WayPar) )
+ , ( "gransim" , NoArg (addNoDups ways WayGran) )
+ , ( "smp" , NoArg (addNoDups ways WaySMP) )
+ , ( "debug" , NoArg (addNoDups ways WayDebug) )
-- ToDo: user ways
------- Interface files ---------------------------------------------
------- Miscellaneous -----------------------------------------------
, ( "cpp" , NoArg (writeIORef cpp_flag True) )
- , ( "#include" , SepArg (add cmdline_hc_includes) )
+ , ( "#include" , HasArg (add cmdline_hc_includes) )
+ , ( "no-link-chk" , NoArg (return ()) ) -- ignored for backwards compat
------- Output Redirection ------------------------------------------
, ( "odir" , HasArg (writeIORef output_dir . Just) )
, ( "optdep" , HasArg (add opt_dep) )
, ( "optL" , HasArg (add opt_L) )
, ( "optP" , HasArg (add opt_P) )
- , ( "optC" , HasArg (add opt_C) )
, ( "optCrts" , HasArg (add opt_Crts) )
+ , ( "optC" , HasArg (add opt_C) )
, ( "optc" , HasArg (add opt_c) )
, ( "optm" , HasArg (add opt_m) )
, ( "opta" , HasArg (add opt_a) )
, ( "fvia-C" , NoArg (writeIORef hsc_lang HscC) )
- , ( "fno-asm-mangling" , NoArg (writeIORef do_asm_mangling True) )
+ , ( "fno-asm-mangling" , NoArg (writeIORef do_asm_mangling False) )
, ( "fmax-simplifier-iterations",
Prefix (writeIORef opt_MaxSimplifierIterations . read) )
findArg :: String -> (String,OptKind)
findArg arg
- = case [ (rest,k) | (pat,k) <- opts,
- Just rest <- [my_prefix_match pat arg],
- is_prefix k || null rest ] of
+ = case [ (remove_spaces rest, k) | (pat,k) <- opts,
+ Just rest <- [my_prefix_match pat arg],
+ is_prefix k || null rest ] of
[] -> throwDyn (UnknownFlag ('-':arg))
(one:_) -> one
-----------------------------------------------------------------------------
-- Finding files in the installation
-GLOBAL_VAR(topDir, _libdir, String)
+GLOBAL_VAR(topDir, clibdir, String)
-- grab the last -B option on the command line, and
-- set topDir to its value.
setTopDir args = do
let (minusbs, others) = partition (prefixMatch "-B") args
(case minusbs of
- [] -> writeIORef topDir _libdir
+ [] -> writeIORef topDir clibdir
some -> writeIORef topDir (drop 2 (last some)))
return others
findFile name alt_path = unsafePerformIO (do
top_dir <- readIORef topDir
let installed_file = top_dir ++ '/':name
- let inplace_file = top_dir ++ '/':_CURRENT_DIR ++ '/':alt_path
+ let inplace_file = top_dir ++ '/':cCURRENT_DIR ++ '/':alt_path
b <- fileExist inplace_file
if b then return inplace_file
else return installed_file
xs <- readIORef var
writeIORef var (x:xs)
+addNoDups :: Eq a => IORef [a] -> a -> IO ()
+addNoDups var x = do
+ xs <- readIORef var
+ if x `elem` xs then return () else writeIORef var (x:xs)
+
remove_suffix :: String -> Char -> String
remove_suffix s c
| null pre = reverse suf
newdir :: String -> String -> String
newdir dir s = dir ++ '/':drop_longest_prefix s '/'
+
+remove_spaces :: String -> String
+remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
projects / ghc-hetmet.git / blobdiff