ghc/compiler/main/DriverPipeline.hs

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