ghc/compiler/main/DriverPipeline.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverPipeline.hs,v 1.1 2000/10/11 15:26:18 simonmar Exp $
   3 --
   4 -- GHC Driver
   5 --
   6 -- (c) Simon Marlow 2000
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module DriverPipeline (
  11    GhcMode(..), getGhcMode, v_GhcMode,
  12    genPipeline, runPipeline,
  13    preprocess,
  14    doLink,
  15   ) where
  16
  17 #include "HsVersions.h"
  18
  19 import CmSummarise -- for mkdependHS stuff
  20 import DriverState
  21 import DriverUtil
  22 import DriverMkDepend
  23 import DriverFlags
  24 import TmpFiles
  25 import Config
  26 import Util
  27 import CmdLineOpts
  28 import Panic
  29
  30 import IOExts
  31 import Posix
  32 import Exception
  33
  34 import IO
  35 import Monad
  36 import Maybe
  37
  38 -----------------------------------------------------------------------------
  39 -- GHC modes of operation
  40
  41 data GhcMode
  42   = DoMkDependHS                        -- ghc -M
  43   | DoMkDLL                             -- ghc -mk-dll
  44   | StopBefore Phase                    -- ghc -E | -C | -S | -c
  45   | DoMake                              -- ghc --make
  46   | DoInteractive                       -- ghc --interactive
  47   | DoLink                              -- [ the default ]
  48   deriving (Eq)
  49
  50 GLOBAL_VAR(v_GhcMode, error "todo", GhcMode)
  51
  52 modeFlag :: String -> Maybe GhcMode
  53 modeFlag "-M"            = Just $ DoMkDependHS
  54 modeFlag "-E"            = Just $ StopBefore Hsc
  55 modeFlag "-C"            = Just $ StopBefore HCc
  56 modeFlag "-S"            = Just $ StopBefore As
  57 modeFlag "-c"            = Just $ StopBefore Ln
  58 modeFlag "--make"        = Just $ DoMake
  59 modeFlag "--interactive" = Just $ DoInteractive
  60 modeFlag _               = Nothing
  61
  62 getGhcMode :: [String]
  63          -> IO ( [String]   -- rest of command line
  64                , GhcMode
  65                , String     -- "GhcMode" flag
  66                )
  67 getGhcMode flags
  68   = case my_partition modeFlag flags of
  69         ([]   , rest) -> return (rest, DoLink,  "") -- default is to do linking
  70         ([(flag,one)], rest) -> return (rest, one, flag)
  71         (_    , _   ) ->
  72           throwDyn (OtherError
  73                 "only one of the flags -M, -E, -C, -S, -c, --make, --interactive is allowed")
  74
  75 -----------------------------------------------------------------------------
  76 -- Phases
  77
  78 {-
  79 Phase of the           | Suffix saying | Flag saying   | (suffix of)
  80 compilation system     | ``start here''| ``stop after''| output file
  81
  82 literate pre-processor | .lhs          | -             | -
  83 C pre-processor (opt.) | -             | -E            | -
  84 Haskell compiler       | .hs           | -C, -S        | .hc, .s
  85 C compiler (opt.)      | .hc or .c     | -S            | .s
  86 assembler              | .s  or .S     | -c            | .o
  87 linker                 | other         | -             | a.out
  88 -}
  89
  90 data Phase
  91         = MkDependHS    -- haskell dependency generation
  92         | Unlit
  93         | Cpp
  94         | Hsc
  95         | Cc
  96         | HCc           -- Haskellised C (as opposed to vanilla C) compilation
  97         | Mangle        -- assembly mangling, now done by a separate script.
  98         | SplitMangle   -- after mangler if splitting
  99         | SplitAs
 100         | As
 101         | Ln
 102   deriving (Eq)
 103
 104 -- the first compilation phase for a given file is determined
 105 -- by its suffix.
 106 startPhase "lhs"   = Unlit
 107 startPhase "hs"    = Cpp
 108 startPhase "hc"    = HCc
 109 startPhase "c"     = Cc
 110 startPhase "raw_s" = Mangle
 111 startPhase "s"     = As
 112 startPhase "S"     = As
 113 startPhase "o"     = Ln
 114 startPhase _       = Ln    -- all unknown file types
 115
 116 -- the output suffix for a given phase is uniquely determined by
 117 -- the input requirements of the next phase.
 118 phase_input_ext Unlit       = "lhs"
 119 phase_input_ext Cpp         = "lpp"     -- intermediate only
 120 phase_input_ext Hsc         = "cpp"     -- intermediate only
 121 phase_input_ext HCc         = "hc"
 122 phase_input_ext Cc          = "c"
 123 phase_input_ext Mangle      = "raw_s"
 124 phase_input_ext SplitMangle = "split_s" -- not really generated
 125 phase_input_ext As          = "s"
 126 phase_input_ext SplitAs     = "split_s" -- not really generated
 127 phase_input_ext Ln          = "o"
 128 phase_input_ext MkDependHS  = "dep"
 129
 130 haskellish_suffix = (`elem` [ "hs", "lhs", "hc" ])
 131 cish_suffix       = (`elem` [ "c", "s", "S" ])  -- maybe .cc et al.??
 132
 133 haskellish_file f = haskellish_suffix suf where (_,suf) = splitFilename f
 134 cish_file f       = cish_suffix suf       where (_,suf) = splitFilename f
 135
 136 -----------------------------------------------------------------------------
 137 -- genPipeline
 138 --
 139 -- Herein is all the magic about which phases to run in which order, whether
 140 -- the intermediate files should be in /tmp or in the current directory,
 141 -- what the suffix of the intermediate files should be, etc.
 142
 143 -- The following compilation pipeline algorithm is fairly hacky.  A
 144 -- better way to do this would be to express the whole comilation as a
 145 -- data flow DAG, where the nodes are the intermediate files and the
 146 -- edges are the compilation phases.  This framework would also work
 147 -- nicely if a haskell dependency generator was included in the
 148 -- driver.
 149
 150 -- It would also deal much more cleanly with compilation phases that
 151 -- generate multiple intermediates, (eg. hsc generates .hc, .hi, and
 152 -- possibly stub files), where some of the output files need to be
 153 -- processed further (eg. the stub files need to be compiled by the C
 154 -- compiler).
 155
 156 -- A cool thing to do would then be to execute the data flow graph
 157 -- concurrently, automatically taking advantage of extra processors on
 158 -- the host machine.  For example, when compiling two Haskell files
 159 -- where one depends on the other, the data flow graph would determine
 160 -- that the C compiler from the first comilation can be overlapped
 161 -- with the hsc comilation for the second file.
 162
 163 data IntermediateFileType
 164   = Temporary
 165   | Persistent
 166   deriving (Eq)
 167
 168 genPipeline
 169    :: GhcMode           -- when to stop
 170    -> String            -- "stop after" flag (for error messages)
 171    -> String            -- original filename
 172    -> IO [              -- list of phases to run for this file
 173              (Phase,
 174               IntermediateFileType,  -- keep the output from this phase?
 175               String)                -- output file suffix
 176          ]
 177
 178 genPipeline todo stop_flag filename
 179  = do
 180    split      <- readIORef split_object_files
 181    mangle     <- readIORef do_asm_mangling
 182    lang       <- readIORef hsc_lang
 183    keep_hc    <- readIORef keep_hc_files
 184    keep_raw_s <- readIORef keep_raw_s_files
 185    keep_s     <- readIORef keep_s_files
 186
 187    let
 188    ----------- -----  ----   ---   --   --  -  -  -
 189     (_basename, suffix) = splitFilename filename
 190
 191     start_phase = startPhase suffix
 192
 193     haskellish = haskellish_suffix suffix
 194     cish = cish_suffix suffix
 195
 196    -- for a .hc file, or if the -C flag is given, we need to force lang to HscC
 197     real_lang
 198         | suffix == "hc"  = HscC
 199         | todo == StopBefore HCc && lang /= HscC && haskellish = HscC
 200         | otherwise = lang
 201
 202    let
 203    ----------- -----  ----   ---   --   --  -  -  -
 204     pipeline
 205       | todo == DoMkDependHS = [ Unlit, Cpp, MkDependHS ]
 206
 207       | haskellish =
 208        case real_lang of
 209         HscC    | split && mangle -> [ Unlit, Cpp, Hsc, HCc, Mangle,
 210                                         SplitMangle, SplitAs ]
 211                 | mangle          -> [ Unlit, Cpp, Hsc, HCc, Mangle, As ]
 212                 | split           -> not_valid
 213                 | otherwise       -> [ Unlit, Cpp, Hsc, HCc, As ]
 214
 215         HscAsm  | split           -> [ Unlit, Cpp, Hsc, SplitMangle, SplitAs ]
 216                 | otherwise       -> [ Unlit, Cpp, Hsc, As ]
 217
 218         HscJava | split           -> not_valid
 219                 | otherwise       -> error "not implemented: compiling via Java"
 220
 221       | cish      = [ Cc, As ]
 222
 223       | otherwise = [ ]  -- just pass this file through to the linker
 224
 225         -- ToDo: this is somewhat cryptic
 226     not_valid = throwDyn (OtherError ("invalid option combination"))
 227    ----------- -----  ----   ---   --   --  -  -  -
 228
 229         -- this shouldn't happen.
 230    if start_phase /= Ln && start_phase `notElem` pipeline
 231         then throwDyn (OtherError ("can't find starting phase for "
 232                                     ++ filename))
 233         else do
 234
 235         -- if we can't find the phase we're supposed to stop before,
 236         -- something has gone wrong.
 237    case todo of
 238         StopBefore phase ->
 239            when (phase /= Ln
 240                  && phase `notElem` pipeline
 241                  && not (phase == As && SplitAs `elem` pipeline)) $
 242               throwDyn (OtherError
 243                 ("flag " ++ stop_flag
 244                  ++ " is incompatible with source file `" ++ filename ++ "'"))
 245         _ -> return ()
 246
 247    let
 248    ----------- -----  ----   ---   --   --  -  -  -
 249       annotatePipeline
 250          :: [Phase]             -- raw pipeline
 251          -> Phase               -- phase to stop before
 252          -> [(Phase, IntermediateFileType, String{-file extension-})]
 253       annotatePipeline []     _    = []
 254       annotatePipeline (Ln:_) _    = []
 255       annotatePipeline (phase:next_phase:ps) stop =
 256           (phase, keep_this_output, phase_input_ext next_phase)
 257              : annotatePipeline (next_phase:ps) stop
 258           where
 259                 keep_this_output
 260                      | next_phase == stop = Persistent
 261                      | otherwise =
 262                         case next_phase of
 263                              Ln -> Persistent
 264                              Mangle | keep_raw_s -> Persistent
 265                              As     | keep_s     -> Persistent
 266                              HCc    | keep_hc    -> Persistent
 267                              _other              -> Temporary
 268
 269         -- add information about output files to the pipeline
 270         -- the suffix on an output file is determined by the next phase
 271         -- in the pipeline, so we add linking to the end of the pipeline
 272         -- to force the output from the final phase to be a .o file.
 273       stop_phase = case todo of StopBefore phase -> phase
 274                                 DoMkDependHS     -> Ln
 275                                 DoLink           -> Ln
 276       annotated_pipeline = annotatePipeline (pipeline ++ [ Ln ]) stop_phase
 277
 278       phase_ne p (p1,_,_) = (p1 /= p)
 279    ----------- -----  ----   ---   --   --  -  -  -
 280
 281    return $
 282      dropWhile (phase_ne start_phase) .
 283         foldr (\p ps -> if phase_ne stop_phase p then p:ps else [])  []
 284                 $ annotated_pipeline
 285
 286
 287 runPipeline
 288   :: [ (Phase, IntermediateFileType, String) ] -- phases to run
 289   -> String                     -- input file
 290   -> Bool                       -- doing linking afterward?
 291   -> Bool                       -- take into account -o when generating output?
 292   -> IO String                  -- return final filename
 293
 294 runPipeline pipeline input_fn do_linking use_ofile
 295   = pipeLoop pipeline input_fn do_linking use_ofile basename suffix
 296   where (basename, suffix) = splitFilename input_fn
 297
 298 pipeLoop [] input_fn _ _ _ _ = return input_fn
 299 pipeLoop ((phase, keep, o_suffix):phases)
 300         input_fn do_linking use_ofile orig_basename orig_suffix
 301   = do
 302
 303      output_fn <- outputFileName (null phases) keep o_suffix
 304
 305      carry_on <- run_phase phase orig_basename orig_suffix input_fn output_fn
 306         -- sometimes we bail out early, eg. when the compiler's recompilation
 307         -- checker has determined that recompilation isn't necessary.
 308      if not carry_on
 309         then do let (_,keep,final_suffix) = last phases
 310                 ofile <- outputFileName True keep final_suffix
 311                 return ofile
 312         else do -- carry on ...
 313
 314         -- sadly, ghc -E is supposed to write the file to stdout.  We
 315         -- generate <file>.cpp, so we also have to cat the file here.
 316      when (null phases && phase == Cpp) $
 317         run_something "Dump pre-processed file to stdout"
 318                       ("cat " ++ output_fn)
 319
 320      pipeLoop phases output_fn do_linking use_ofile orig_basename orig_suffix
 321
 322   where
 323      outputFileName last_phase keep suffix
 324         = do o_file <- readIORef output_file
 325              if last_phase && not do_linking && use_ofile && isJust o_file
 326                then case o_file of
 327                        Just s  -> return s
 328                        Nothing -> error "outputFileName"
 329                else if keep == Persistent
 330                            then do f <- odir_ify (orig_basename ++ '.':suffix)
 331                                    osuf_ify f
 332                            else newTempName suffix
 333
 334 -------------------------------------------------------------------------------
 335 -- Unlit phase
 336
 337 run_phase Unlit _basename _suff input_fn output_fn
 338   = do unlit <- readIORef pgm_L
 339        unlit_flags <- getOpts opt_L
 340        run_something "Literate pre-processor"
 341           ("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
 342            ++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
 343        return True
 344
 345 -------------------------------------------------------------------------------
 346 -- Cpp phase
 347
 348 run_phase Cpp _basename _suff input_fn output_fn
 349   = do src_opts <- getOptionsFromSource input_fn
 350         -- ToDo: this is *wrong* if we're processing more than one file:
 351         -- the OPTIONS will persist through the subsequent compilations.
 352        _ <- processArgs dynamic_flags src_opts []
 353
 354        do_cpp <- readState cpp_flag
 355        if do_cpp
 356           then do
 357             cpp <- readIORef pgm_P
 358             hscpp_opts <- getOpts opt_P
 359             hs_src_cpp_opts <- readIORef hs_source_cpp_opts
 360
 361             cmdline_include_paths <- readIORef include_paths
 362             pkg_include_dirs <- getPackageIncludePath
 363             let include_paths = map (\p -> "-I"++p) (cmdline_include_paths
 364                                                         ++ pkg_include_dirs)
 365
 366             verb <- is_verbose
 367             run_something "C pre-processor"
 368                 (unwords
 369                    (["echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}'", ">", output_fn, "&&",
 370                      cpp, verb]
 371                     ++ include_paths
 372                     ++ hs_src_cpp_opts
 373                     ++ hscpp_opts
 374                     ++ [ "-x", "c", input_fn, ">>", output_fn ]
 375                    ))
 376           else do
 377             run_something "Ineffective C pre-processor"
 378                    ("echo '{-# LINE 1 \""  ++ input_fn ++ "\" -}' > "
 379                     ++ output_fn ++ " && cat " ++ input_fn
 380                     ++ " >> " ++ output_fn)
 381        return True
 382
 383 -----------------------------------------------------------------------------
 384 -- MkDependHS phase
 385
 386 run_phase MkDependHS basename suff input_fn _output_fn = do
 387    src <- readFile input_fn
 388    let imports = getImports src
 389
 390    deps <- mapM (findDependency basename) imports
 391
 392    osuf_opt <- readIORef output_suf
 393    let osuf = case osuf_opt of
 394                         Nothing -> "o"
 395                         Just s  -> s
 396
 397    extra_suffixes <- readIORef dep_suffixes
 398    let suffixes = osuf : map (++ ('_':osuf)) extra_suffixes
 399        ofiles = map (\suf -> basename ++ '.':suf) suffixes
 400
 401    objs <- mapM odir_ify ofiles
 402
 403    hdl <- readIORef dep_tmp_hdl
 404
 405         -- std dependeny of the object(s) on the source file
 406    hPutStrLn hdl (unwords objs ++ " : " ++ basename ++ '.':suff)
 407
 408    let genDep (dep, False {- not an hi file -}) =
 409           hPutStrLn hdl (unwords objs ++ " : " ++ dep)
 410        genDep (dep, True  {- is an hi file -}) = do
 411           hisuf <- readIORef hi_suf
 412           let dep_base = remove_suffix '.' dep
 413               deps = (dep_base ++ hisuf)
 414                      : map (\suf -> dep_base ++ suf ++ '_':hisuf) extra_suffixes
 415                   -- length objs should be == length deps
 416           sequence_ (zipWith (\o d -> hPutStrLn hdl (o ++ " : " ++ d)) objs deps)
 417
 418    mapM genDep [ d | Just d <- deps ]
 419
 420    return True
 421
 422 -- add the lines to dep_makefile:
 423            -- always:
 424                    -- this.o : this.hs
 425
 426            -- if the dependency is on something other than a .hi file:
 427                    -- this.o this.p_o ... : dep
 428            -- otherwise
 429                    -- if the import is {-# SOURCE #-}
 430                            -- this.o this.p_o ... : dep.hi-boot[-$vers]
 431
 432                    -- else
 433                            -- this.o ...   : dep.hi
 434                            -- this.p_o ... : dep.p_hi
 435                            -- ...
 436
 437            -- (where .o is $osuf, and the other suffixes come from
 438            -- the cmdline -s options).
 439
 440 -----------------------------------------------------------------------------
 441 -- Hsc phase
 442
 443 {-
 444 run_phase Hsc   basename suff input_fn output_fn
 445   = do  hsc <- readIORef pgm_C
 446
 447   -- we add the current directory (i.e. the directory in which
 448   -- the .hs files resides) to the import path, since this is
 449   -- what gcc does, and it's probably what you want.
 450         let current_dir = getdir basename
 451
 452         paths <- readIORef include_paths
 453         writeIORef include_paths (current_dir : paths)
 454
 455   -- build the hsc command line
 456         hsc_opts <- build_hsc_opts
 457
 458         doing_hi <- readIORef produceHi
 459         tmp_hi_file <- if doing_hi
 460                           then newTempName "hi"
 461                           else return ""
 462
 463   -- tmp files for foreign export stub code
 464         tmp_stub_h <- newTempName "stub_h"
 465         tmp_stub_c <- newTempName "stub_c"
 466
 467   -- figure out where to put the .hi file
 468         ohi    <- readIORef output_hi
 469         hisuf  <- readIORef hi_suf
 470         let hi_flags = case ohi of
 471                            Nothing -> [ "-hidir="++current_dir, "-hisuf="++hisuf ]
 472                            Just fn -> [ "-hifile="++fn ]
 473
 474   -- figure out if the source has changed, for recompilation avoidance.
 475   -- only do this if we're eventually going to generate a .o file.
 476   -- (ToDo: do when generating .hc files too?)
 477   --
 478   -- Setting source_unchanged to "-fsource_unchanged" means that M.o seems
 479   -- to be up to date wrt M.hs; so no need to recompile unless imports have
 480   -- changed (which the compiler itself figures out).
 481   -- Setting source_unchanged to "" tells the compiler that M.o is out of
 482   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
 483         do_recomp <- readIORef recomp
 484         todo <- readIORef v_GhcMode
 485         o_file <- odir_ify (basename ++ '.':phase_input_ext Ln)
 486         source_unchanged <-
 487           if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
 488              then return ""
 489              else do t1 <- getModificationTime (basename ++ '.':suff)
 490                      o_file_exists <- doesFileExist o_file
 491                      if not o_file_exists
 492                         then return ""  -- Need to recompile
 493                         else do t2 <- getModificationTime o_file
 494                                 if t2 > t1
 495                                   then return "-fsource-unchanged"
 496                                   else return ""
 497
 498   -- run the compiler!
 499         run_something "Haskell Compiler"
 500                  (unwords (hsc : input_fn : (
 501                     hsc_opts
 502                     ++ hi_flags
 503                     ++ [
 504                           source_unchanged,
 505                           "-ofile="++output_fn,
 506                           "-F="++tmp_stub_c,
 507                           "-FH="++tmp_stub_h
 508                        ]
 509                  )))
 510
 511   -- check whether compilation was performed, bail out if not
 512         b <- doesFileExist output_fn
 513         if not b && not (null source_unchanged) -- sanity
 514                 then do run_something "Touching object file"
 515                             ("touch " ++ o_file)
 516                         return False
 517                 else do -- carry on...
 518
 519   -- Deal with stubs
 520         let stub_h = basename ++ "_stub.h"
 521         let stub_c = basename ++ "_stub.c"
 522
 523                 -- copy .h_stub file into current dir if present
 524         b <- doesFileExist tmp_stub_h
 525         when b (do
 526                 run_something "Copy stub .h file"
 527                                 ("cp " ++ tmp_stub_h ++ ' ':stub_h)
 528
 529                         -- #include <..._stub.h> in .hc file
 530                 addCmdlineHCInclude tmp_stub_h  -- hack
 531
 532                         -- copy the _stub.c file into the current dir
 533                 run_something "Copy stub .c file"
 534                     (unwords [
 535                         "rm -f", stub_c, "&&",
 536                         "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
 537                         "cat", tmp_stub_c, ">> ", stub_c
 538                         ])
 539
 540                         -- compile the _stub.c file w/ gcc
 541                 pipeline <- genPipeline (StopBefore Ln) "" stub_c
 542                 runPipeline pipeline stub_c False{-no linking-} False{-no -o option-}
 543
 544                 add ld_inputs (basename++"_stub.o")
 545          )
 546         return True
 547 -}
 548
 549 -----------------------------------------------------------------------------
 550 -- Cc phase
 551
 552 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 553 -- way too many hacks, and I can't say I've ever used it anyway.
 554
 555 run_phase cc_phase _basename _suff input_fn output_fn
 556    | cc_phase == Cc || cc_phase == HCc
 557    = do cc <- readIORef pgm_c
 558         cc_opts <- (getOpts opt_c)
 559         cmdline_include_dirs <- readIORef include_paths
 560
 561         let hcc = cc_phase == HCc
 562
 563                 -- add package include paths even if we're just compiling
 564                 -- .c files; this is the Value Add(TM) that using
 565                 -- ghc instead of gcc gives you :)
 566         pkg_include_dirs <- getPackageIncludePath
 567         let include_paths = map (\p -> "-I"++p) (cmdline_include_dirs
 568                                                         ++ pkg_include_dirs)
 569
 570         c_includes <- getPackageCIncludes
 571         cmdline_includes <- readState cmdline_hc_includes -- -#include options
 572
 573         let cc_injects | hcc = unlines (map mk_include
 574                                         (c_includes ++ reverse cmdline_includes))
 575                        | otherwise = ""
 576             mk_include h_file =
 577                 case h_file of
 578                    '"':_{-"-} -> "#include "++h_file
 579                    '<':_      -> "#include "++h_file
 580                    _          -> "#include \""++h_file++"\""
 581
 582         cc_help <- newTempName "c"
 583         h <- openFile cc_help WriteMode
 584         hPutStr h cc_injects
 585         hPutStrLn h ("#include \"" ++ input_fn ++ "\"\n")
 586         hClose h
 587
 588         ccout <- newTempName "ccout"
 589
 590         mangle <- readIORef do_asm_mangling
 591         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
 592
 593         verb <- is_verbose
 594
 595         o2 <- readIORef opt_minus_o2_for_C
 596         let opt_flag | o2        = "-O2"
 597                      | otherwise = "-O"
 598
 599         pkg_extra_cc_opts <- getPackageExtraCcOpts
 600
 601         excessPrecision <- readIORef excess_precision
 602
 603         run_something "C Compiler"
 604          (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
 605                    ++ md_c_flags
 606                    ++ (if cc_phase == HCc && mangle
 607                          then md_regd_c_flags
 608                          else [])
 609                    ++ [ verb, "-S", "-Wimplicit", opt_flag ]
 610                    ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 611                    ++ cc_opts
 612 #ifdef mingw32_TARGET_OS
 613                    ++ [" -mno-cygwin"]
 614 #endif
 615                    ++ (if excessPrecision then [] else [ "-ffloat-store" ])
 616                    ++ include_paths
 617                    ++ pkg_extra_cc_opts
 618 --                 ++ [">", ccout]
 619                    ))
 620         return True
 621
 622         -- ToDo: postprocess the output from gcc
 623
 624 -----------------------------------------------------------------------------
 625 -- Mangle phase
 626
 627 run_phase Mangle _basename _suff input_fn output_fn
 628   = do mangler <- readIORef pgm_m
 629        mangler_opts <- getOpts opt_m
 630        machdep_opts <-
 631          if (prefixMatch "i386" cTARGETPLATFORM)
 632             then do n_regs <- readState stolen_x86_regs
 633                     return [ show n_regs ]
 634             else return []
 635        run_something "Assembly Mangler"
 636         (unwords (mangler :
 637                      mangler_opts
 638                   ++ [ input_fn, output_fn ]
 639                   ++ machdep_opts
 640                 ))
 641        return True
 642
 643 -----------------------------------------------------------------------------
 644 -- Splitting phase
 645
 646 run_phase SplitMangle _basename _suff input_fn _output_fn
 647   = do  splitter <- readIORef pgm_s
 648
 649         -- this is the prefix used for the split .s files
 650         tmp_pfx <- readIORef v_TmpDir
 651         x <- getProcessID
 652         let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
 653         writeIORef split_prefix split_s_prefix
 654         addFilesToClean [split_s_prefix ++ "__*"] -- d:-)
 655
 656         -- allocate a tmp file to put the no. of split .s files in (sigh)
 657         n_files <- newTempName "n_files"
 658
 659         run_something "Split Assembly File"
 660          (unwords [ splitter
 661                   , input_fn
 662                   , split_s_prefix
 663                   , n_files ]
 664          )
 665
 666         -- save the number of split files for future references
 667         s <- readFile n_files
 668         let n = read s :: Int
 669         writeIORef n_split_files n
 670         return True
 671
 672 -----------------------------------------------------------------------------
 673 -- As phase
 674
 675 run_phase As _basename _suff input_fn output_fn
 676   = do  as <- readIORef pgm_a
 677         as_opts <- getOpts opt_a
 678
 679         cmdline_include_paths <- readIORef include_paths
 680         let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
 681         run_something "Assembler"
 682            (unwords (as : as_opts
 683                        ++ cmdline_include_flags
 684                        ++ [ "-c", input_fn, "-o",  output_fn ]
 685                     ))
 686         return True
 687
 688 run_phase SplitAs basename _suff _input_fn _output_fn
 689   = do  as <- readIORef pgm_a
 690         as_opts <- getOpts opt_a
 691
 692         split_s_prefix <- readIORef split_prefix
 693         n <- readIORef n_split_files
 694
 695         odir <- readIORef output_dir
 696         let real_odir = case odir of
 697                                 Nothing -> basename
 698                                 Just d  -> d
 699
 700         let assemble_file n = do
 701                     let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
 702                     let output_o = newdir real_odir
 703                                         (basename ++ "__" ++ show n ++ ".o")
 704                     real_o <- osuf_ify output_o
 705                     run_something "Assembler"
 706                             (unwords (as : as_opts
 707                                       ++ [ "-c", "-o", real_o, input_s ]
 708                             ))
 709
 710         mapM_ assemble_file [1..n]
 711         return True
 712
 713 -----------------------------------------------------------------------------
 714 -- Linking
 715
 716 doLink :: [String] -> IO ()
 717 doLink o_files = do
 718     ln <- readIORef pgm_l
 719     verb <- is_verbose
 720     o_file <- readIORef output_file
 721     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
 722
 723     pkg_lib_paths <- getPackageLibraryPath
 724     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
 725
 726     lib_paths <- readIORef library_paths
 727     let lib_path_opts = map ("-L"++) lib_paths
 728
 729     pkg_libs <- getPackageLibraries
 730     let pkg_lib_opts = map (\lib -> "-l"++lib) pkg_libs
 731
 732     libs <- readIORef cmdline_libraries
 733     let lib_opts = map ("-l"++) (reverse libs)
 734          -- reverse because they're added in reverse order from the cmd line
 735
 736     pkg_extra_ld_opts <- getPackageExtraLdOpts
 737
 738         -- probably _stub.o files
 739     extra_ld_inputs <- readIORef ld_inputs
 740
 741         -- opts from -optl-<blah>
 742     extra_ld_opts <- getStaticOpts opt_l
 743
 744     run_something "Linker"
 745        (unwords
 746          ([ ln, verb, "-o", output_fn ]
 747          ++ o_files
 748          ++ extra_ld_inputs
 749          ++ lib_path_opts
 750          ++ lib_opts
 751          ++ pkg_lib_path_opts
 752          ++ pkg_lib_opts
 753          ++ pkg_extra_ld_opts
 754          ++ extra_ld_opts
 755         )
 756        )
 757
 758 -----------------------------------------------------------------------------
 759 -- Just preprocess a file, put the result in a temp. file (used by the
 760 -- compilation manager during the summary phase).
 761
 762 preprocess :: FilePath -> IO FilePath
 763 preprocess filename =
 764   ASSERT(haskellish_file filename)
 765   do pipeline <- genPipeline (StopBefore Hsc) ("preprocess") filename
 766      runPipeline pipeline filename False{-no linking-} False{-no -o flag-}