------------------------------------------------------------------------------
--- 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_todo
- 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
- ]
- ++ stat_opts
- )))
-
- -- check whether compilation was performed, bail out if not
- b <- doesFileExist output_fn
- if not b && not (null source_unchanged) -- sanity
- then do run_something "Touching object file"
- ("touch " ++ o_file)
- return False
- else do -- carry on...
-
- -- Deal with stubs
- let stub_h = basename ++ "_stub.h"
- let stub_c = basename ++ "_stub.c"
-
- -- copy .h_stub file into current dir if present
- b <- doesFileExist tmp_stub_h
- when b (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
- 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
- run_pipeline pipeline stub_c False{-no linking-}
- False{-no -o option-}
- (basename++"_stub") "c"
-
- add ld_inputs (basename++"_stub.o")
- )
- return True
-
------------------------------------------------------------------------------
--- Cc phase
-
--- we don't support preprocessing .c files (with -E) now. Doing so introduces
--- way too many hacks, and I can't say I've ever used it anyway.
-
-run_phase cc_phase _basename _suff input_fn output_fn
- | cc_phase == Cc || cc_phase == HCc
- = do cc <- readIORef pgm_c
- cc_opts <- (getOpts opt_c)
- cmdline_include_dirs <- readIORef include_paths
-
- let hcc = cc_phase == HCc
-
- -- add package include paths even if we're just compiling
- -- .c files; this is the Value Add(TM) that using
- -- ghc instead of gcc gives you :)
- pkg_include_dirs <- getPackageIncludePath
- let include_paths = map (\p -> "-I"++p) (cmdline_include_dirs
- ++ pkg_include_dirs)
-
- c_includes <- getPackageCIncludes
- cmdline_includes <- readState cmdline_hc_includes -- -#include options
-
- let cc_injects | hcc = unlines (map mk_include
- (c_includes ++ reverse cmdline_includes))
- | otherwise = ""
- mk_include h_file =
- case h_file of
- '"':_{-"-} -> "#include "++h_file
- '<':_ -> "#include "++h_file
- _ -> "#include \""++h_file++"\""
-
- cc_help <- newTempName "c"
- h <- openFile cc_help WriteMode
- hPutStr h cc_injects
- hPutStrLn h ("#include \"" ++ input_fn ++ "\"\n")
- hClose h
-
- ccout <- newTempName "ccout"
-
- mangle <- readIORef do_asm_mangling
- (md_c_flags, md_regd_c_flags) <- machdepCCOpts
-
- verb <- is_verbose
-
- o2 <- readIORef opt_minus_o2_for_C
- let opt_flag | o2 = "-O2"
- | otherwise = "-O"
-
- pkg_extra_cc_opts <- getPackageExtraCcOpts
-
- excessPrecision <- readState excess_precision
-
- run_something "C Compiler"
- (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
- ++ md_c_flags
- ++ (if cc_phase == HCc && mangle
- then md_regd_c_flags
- else [])
- ++ [ verb, "-S", "-Wimplicit", opt_flag ]
- ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
- ++ cc_opts
-#ifdef mingw32_TARGET_OS
- ++ [" -mno-cygwin"]
-#endif
- ++ (if excessPrecision then [] else [ "-ffloat-store" ])
- ++ include_paths
- ++ pkg_extra_cc_opts
--- ++ [">", ccout]
- ))
- return True
-
- -- ToDo: postprocess the output from gcc
-
------------------------------------------------------------------------------
--- Mangle phase
-
-run_phase Mangle _basename _suff input_fn output_fn
- = do mangler <- readIORef pgm_m
- mangler_opts <- getOpts opt_m
- machdep_opts <-
- if (prefixMatch "i386" cTARGETPLATFORM)
- then do n_regs <- readState stolen_x86_regs
- return [ show n_regs ]
- else return []
- run_something "Assembly Mangler"
- (unwords (mangler :
- mangler_opts
- ++ [ input_fn, output_fn ]
- ++ machdep_opts
- ))
- return True
-
------------------------------------------------------------------------------
--- Splitting phase
-
-run_phase SplitMangle _basename _suff input_fn _output_fn
- = do splitter <- readIORef pgm_s
-
- -- this is the prefix used for the split .s files
- tmp_pfx <- readIORef tmpdir
- x <- getProcessID
- let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
- writeIORef split_prefix split_s_prefix
- addFilesToClean (split_s_prefix ++ "__*") -- d:-)
-
- -- allocate a tmp file to put the no. of split .s files in (sigh)
- n_files <- newTempName "n_files"
-
- run_something "Split Assembly File"
- (unwords [ splitter
- , input_fn
- , split_s_prefix
- , n_files ]
- )
-
- -- save the number of split files for future references
- s <- readFile n_files
- let n = read s :: Int
- writeIORef n_split_files n
- return True
-
------------------------------------------------------------------------------
--- As phase
-
-run_phase As _basename _suff input_fn output_fn
- = 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 ]
- ))
- return True
-
-run_phase SplitAs basename _suff _input_fn _output_fn
- = do as <- readIORef pgm_a
- as_opts <- getOpts opt_a
-
- 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 input_s = split_s_prefix ++ "__" ++ show n ++ ".s"
- let output_o = newdir real_odir
- (basename ++ "__" ++ show n ++ ".o")
- real_o <- osuf_ify output_o
- run_something "Assembler"
- (unwords (as : as_opts
- ++ [ "-c", "-o", real_o, input_s ]
- ))
-
- mapM_ assemble_file [1..n]
- return True
-
------------------------------------------------------------------------------
--- Linking
-
-do_link :: [String] -> IO ()
-do_link o_files = do
- ln <- readIORef pgm_l
- verb <- is_verbose
- o_file <- readIORef output_file
- let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
-
- pkg_lib_paths <- getPackageLibraryPath
- let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
-
- lib_paths <- readIORef library_paths
- let lib_path_opts = map ("-L"++) lib_paths
-
- pkg_libs <- getPackageLibraries
- let pkg_lib_opts = map (\lib -> "-l"++lib) pkg_libs
-
- libs <- readIORef cmdline_libraries
- let lib_opts = map ("-l"++) (reverse libs)
- -- reverse because they're added in reverse order from the cmd line
-
- pkg_extra_ld_opts <- getPackageExtraLdOpts
-
- -- 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 ]
- ++ o_files
- ++ extra_ld_inputs
- ++ lib_path_opts
- ++ lib_opts
- ++ pkg_lib_path_opts
- ++ pkg_lib_opts
- ++ pkg_extra_ld_opts
- ++ extra_ld_opts
- )
- )
-
------------------------------------------------------------------------------
--- compatibility code
-
-#if __GLASGOW_HASKELL__ <= 408
-catchJust = catchIO
-ioErrors = justIoErrors
-#endif
-
-#ifdef mingw32_TARGET_OS
-foreign import "_getpid" getProcessID :: IO Int
-#endif