ghc/compiler/main/DriverPipeline.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverPipeline.hs,v 1.18 2000/11/09 12:54:08 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, CompResult(..),
  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 HscMain
  33 import TmpFiles
  34 import HscTypes
  35 import Outputable
  36 import Module
  37 import CmdLineOpts
  38 import Config
  39 import Util
  40
  41 import Directory
  42 import System
  43 import IOExts
  44 import Exception
  45
  46 import IO
  47 import Monad
  48 import Maybe
  49
  50 -----------------------------------------------------------------------------
  51 -- GHC modes of operation
  52
  53 data GhcMode
  54   = DoMkDependHS                        -- ghc -M
  55   | DoMkDLL                             -- ghc -mk-dll
  56   | StopBefore Phase                    -- ghc -E | -C | -S | -c
  57   | DoMake                              -- ghc --make
  58   | DoInteractive                       -- ghc --interactive
  59   | DoLink                              -- [ the default ]
  60   deriving (Eq)
  61
  62 GLOBAL_VAR(v_GhcMode, error "todo", GhcMode)
  63
  64 modeFlag :: String -> Maybe GhcMode
  65 modeFlag "-M"            = Just $ DoMkDependHS
  66 modeFlag "-E"            = Just $ StopBefore Hsc
  67 modeFlag "-C"            = Just $ StopBefore HCc
  68 modeFlag "-S"            = Just $ StopBefore As
  69 modeFlag "-c"            = Just $ StopBefore Ln
  70 modeFlag "--make"        = Just $ DoMake
  71 modeFlag "--interactive" = Just $ DoInteractive
  72 modeFlag _               = Nothing
  73
  74 getGhcMode :: [String]
  75          -> IO ( [String]   -- rest of command line
  76                , GhcMode
  77                , String     -- "GhcMode" flag
  78                )
  79 getGhcMode flags
  80   = case my_partition modeFlag flags of
  81         ([]   , rest) -> return (rest, DoLink,  "") -- default is to do linking
  82         ([(flag,one)], rest) -> return (rest, one, flag)
  83         (_    , _   ) ->
  84           throwDyn (OtherError
  85                 "only one of the flags -M, -E, -C, -S, -c, --make, --interactive is allowed")
  86
  87 -----------------------------------------------------------------------------
  88 -- genPipeline
  89 --
  90 -- Herein is all the magic about which phases to run in which order, whether
  91 -- the intermediate files should be in /tmp or in the current directory,
  92 -- what the suffix of the intermediate files should be, etc.
  93
  94 -- The following compilation pipeline algorithm is fairly hacky.  A
  95 -- better way to do this would be to express the whole comilation as a
  96 -- data flow DAG, where the nodes are the intermediate files and the
  97 -- edges are the compilation phases.  This framework would also work
  98 -- nicely if a haskell dependency generator was included in the
  99 -- driver.
 100
 101 -- It would also deal much more cleanly with compilation phases that
 102 -- generate multiple intermediates, (eg. hsc generates .hc, .hi, and
 103 -- possibly stub files), where some of the output files need to be
 104 -- processed further (eg. the stub files need to be compiled by the C
 105 -- compiler).
 106
 107 -- A cool thing to do would then be to execute the data flow graph
 108 -- concurrently, automatically taking advantage of extra processors on
 109 -- the host machine.  For example, when compiling two Haskell files
 110 -- where one depends on the other, the data flow graph would determine
 111 -- that the C compiler from the first comilation can be overlapped
 112 -- with the hsc comilation for the second file.
 113
 114 data IntermediateFileType
 115   = Temporary
 116   | Persistent
 117   deriving (Eq)
 118
 119 genPipeline
 120    :: GhcMode           -- when to stop
 121    -> String            -- "stop after" flag (for error messages)
 122    -> String            -- original filename
 123    -> IO [              -- list of phases to run for this file
 124              (Phase,
 125               IntermediateFileType,  -- keep the output from this phase?
 126               String)                -- output file suffix
 127          ]
 128
 129 genPipeline todo stop_flag filename
 130  = do
 131    split      <- readIORef v_Split_object_files
 132    mangle     <- readIORef v_Do_asm_mangling
 133    lang       <- readIORef v_Hsc_Lang
 134    keep_hc    <- readIORef v_Keep_hc_files
 135    keep_raw_s <- readIORef v_Keep_raw_s_files
 136    keep_s     <- readIORef v_Keep_s_files
 137    osuf       <- readIORef v_Object_suf
 138
 139    let
 140    ----------- -----  ----   ---   --   --  -  -  -
 141     (_basename, suffix) = splitFilename filename
 142
 143     start_phase = startPhase suffix
 144
 145     haskellish = haskellish_suffix suffix
 146     cish = cish_suffix suffix
 147
 148    -- for a .hc file, or if the -C flag is given, we need to force lang to HscC
 149     real_lang | suffix == "hc"  = HscC
 150               | otherwise       = lang
 151
 152    let
 153    ----------- -----  ----   ---   --   --  -  -  -
 154     pipeline
 155       | todo == DoMkDependHS = [ Unlit, Cpp, MkDependHS ]
 156
 157       | haskellish =
 158        case real_lang of
 159         HscC    | split && mangle -> [ Unlit, Cpp, Hsc, HCc, Mangle,
 160                                         SplitMangle, SplitAs ]
 161                 | mangle          -> [ Unlit, Cpp, Hsc, HCc, Mangle, As ]
 162                 | split           -> not_valid
 163                 | otherwise       -> [ Unlit, Cpp, Hsc, HCc, As ]
 164
 165         HscAsm  | split           -> [ Unlit, Cpp, Hsc, SplitMangle, SplitAs ]
 166                 | otherwise       -> [ Unlit, Cpp, Hsc, As ]
 167
 168         HscJava | split           -> not_valid
 169                 | otherwise       -> error "not implemented: compiling via Java"
 170
 171       | cish      = [ Cc, As ]
 172
 173       | otherwise = [ ]  -- just pass this file through to the linker
 174
 175         -- ToDo: this is somewhat cryptic
 176     not_valid = throwDyn (OtherError ("invalid option combination"))
 177    ----------- -----  ----   ---   --   --  -  -  -
 178
 179         -- this shouldn't happen.
 180    if start_phase /= Ln && start_phase `notElem` pipeline
 181         then throwDyn (OtherError ("can't find starting phase for "
 182                                     ++ filename))
 183         else do
 184
 185         -- if we can't find the phase we're supposed to stop before,
 186         -- something has gone wrong.
 187    case todo of
 188         StopBefore phase ->
 189            when (phase /= Ln
 190                  && phase `notElem` pipeline
 191                  && not (phase == As && SplitAs `elem` pipeline)) $
 192               throwDyn (OtherError
 193                 ("flag " ++ stop_flag
 194                  ++ " is incompatible with source file `" ++ filename ++ "'"))
 195         _ -> return ()
 196
 197    let
 198    ----------- -----  ----   ---   --   --  -  -  -
 199       myPhaseInputExt Ln = case osuf of Nothing -> phaseInputExt Ln
 200                                         Just s  -> s
 201       myPhaseInputExt other = phaseInputExt other
 202
 203       annotatePipeline
 204          :: [Phase]             -- raw pipeline
 205          -> Phase               -- phase to stop before
 206          -> [(Phase, IntermediateFileType, String{-file extension-})]
 207       annotatePipeline []     _    = []
 208       annotatePipeline (Ln:_) _    = []
 209       annotatePipeline (phase:next_phase:ps) stop =
 210           (phase, keep_this_output, myPhaseInputExt next_phase)
 211              : annotatePipeline (next_phase:ps) stop
 212           where
 213                 keep_this_output
 214                      | next_phase == stop = Persistent
 215                      | otherwise =
 216                         case next_phase of
 217                              Ln -> Persistent
 218                              Mangle | keep_raw_s -> Persistent
 219                              As     | keep_s     -> Persistent
 220                              HCc    | keep_hc    -> Persistent
 221                              _other              -> Temporary
 222
 223         -- add information about output files to the pipeline
 224         -- the suffix on an output file is determined by the next phase
 225         -- in the pipeline, so we add linking to the end of the pipeline
 226         -- to force the output from the final phase to be a .o file.
 227       stop_phase = case todo of StopBefore phase -> phase
 228                                 DoMkDependHS     -> Ln
 229                                 DoLink           -> Ln
 230       annotated_pipeline = annotatePipeline (pipeline ++ [ Ln ]) stop_phase
 231
 232       phase_ne p (p1,_,_) = (p1 /= p)
 233    ----------- -----  ----   ---   --   --  -  -  -
 234
 235    return $
 236      dropWhile (phase_ne start_phase) .
 237         foldr (\p ps -> if phase_ne stop_phase p then p:ps else [])  []
 238                 $ annotated_pipeline
 239
 240
 241 runPipeline
 242   :: [ (Phase, IntermediateFileType, String) ] -- phases to run
 243   -> String                     -- input file
 244   -> Bool                       -- doing linking afterward?
 245   -> Bool                       -- take into account -o when generating output?
 246   -> IO String                  -- return final filename
 247
 248 runPipeline pipeline input_fn do_linking use_ofile
 249   = pipeLoop pipeline input_fn do_linking use_ofile basename suffix
 250   where (basename, suffix) = splitFilename input_fn
 251
 252 pipeLoop [] input_fn _ _ _ _ = return input_fn
 253 pipeLoop ((phase, keep, o_suffix):phases)
 254         input_fn do_linking use_ofile orig_basename orig_suffix
 255   = do
 256
 257      output_fn <- outputFileName (null phases) keep o_suffix
 258
 259      carry_on <- run_phase phase orig_basename orig_suffix input_fn output_fn
 260         -- sometimes we bail out early, eg. when the compiler's recompilation
 261         -- checker has determined that recompilation isn't necessary.
 262      if not carry_on
 263         then do let (_,keep,final_suffix) = last phases
 264                 ofile <- outputFileName True keep final_suffix
 265                 return ofile
 266         else do -- carry on ...
 267
 268         -- sadly, ghc -E is supposed to write the file to stdout.  We
 269         -- generate <file>.cpp, so we also have to cat the file here.
 270      when (null phases && phase == Cpp) $
 271         run_something "Dump pre-processed file to stdout"
 272                       ("cat " ++ output_fn)
 273
 274      pipeLoop phases output_fn do_linking use_ofile orig_basename orig_suffix
 275
 276   where
 277      outputFileName last_phase keep suffix
 278         = do o_file <- readIORef v_Output_file
 279              if last_phase && not do_linking && use_ofile && isJust o_file
 280                then case o_file of
 281                        Just s  -> return s
 282                        Nothing -> error "outputFileName"
 283                else if keep == Persistent
 284                            then odir_ify (orig_basename ++ '.':suffix)
 285                            else newTempName suffix
 286
 287 -------------------------------------------------------------------------------
 288 -- Unlit phase
 289
 290 run_phase Unlit _basename _suff input_fn output_fn
 291   = do unlit <- readIORef v_Pgm_L
 292        unlit_flags <- getOpts opt_L
 293        run_something "Literate pre-processor"
 294           ("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
 295            ++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
 296        return True
 297
 298 -------------------------------------------------------------------------------
 299 -- Cpp phase
 300
 301 run_phase Cpp basename suff input_fn output_fn
 302   = do src_opts <- getOptionsFromSource input_fn
 303        unhandled_flags <- processArgs dynamic_flags src_opts []
 304
 305        when (not (null unhandled_flags))
 306             (throwDyn (OtherError (
 307                           basename ++ "." ++ suff
 308                           ++ ": static flags are not allowed in {-# OPTIONS #-} pragmas:\n\t"
 309                           ++ unwords unhandled_flags)) (ExitFailure 1))
 310
 311        do_cpp <- readState cpp_flag
 312        if do_cpp
 313           then do
 314             cpp <- readIORef v_Pgm_P
 315             hscpp_opts <- getOpts opt_P
 316             hs_src_cpp_opts <- readIORef v_Hs_source_cpp_opts
 317
 318             cmdline_include_paths <- readIORef v_Include_paths
 319             pkg_include_dirs <- getPackageIncludePath
 320             let include_paths = map (\p -> "-I"++p) (cmdline_include_paths
 321                                                         ++ pkg_include_dirs)
 322
 323             verb <- is_verbose
 324             run_something "C pre-processor"
 325                 (unwords
 326                    (["echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}'", ">", output_fn, "&&",
 327                      cpp, verb]
 328                     ++ include_paths
 329                     ++ hs_src_cpp_opts
 330                     ++ hscpp_opts
 331                     ++ [ "-x", "c", input_fn, ">>", output_fn ]
 332                    ))
 333           else do
 334             run_something "Ineffective C pre-processor"
 335                    ("echo '{-# LINE 1 \""  ++ input_fn ++ "\" -}' > "
 336                     ++ output_fn ++ " && cat " ++ input_fn
 337                     ++ " >> " ++ output_fn)
 338        return True
 339
 340 -----------------------------------------------------------------------------
 341 -- MkDependHS phase
 342
 343 run_phase MkDependHS basename suff input_fn _output_fn = do
 344    src <- readFile input_fn
 345    let imports = getImports src
 346
 347    deps <- mapM (findDependency basename) imports
 348
 349    osuf_opt <- readIORef v_Object_suf
 350    let osuf = case osuf_opt of
 351                         Nothing -> phaseInputExt Ln
 352                         Just s  -> s
 353
 354    extra_suffixes <- readIORef v_Dep_suffixes
 355    let suffixes = osuf : map (++ ('_':osuf)) extra_suffixes
 356        ofiles = map (\suf -> basename ++ '.':suf) suffixes
 357
 358    objs <- mapM odir_ify ofiles
 359
 360    hdl <- readIORef v_Dep_tmp_hdl
 361
 362         -- std dependency of the object(s) on the source file
 363    hPutStrLn hdl (unwords objs ++ " : " ++ basename ++ '.':suff)
 364
 365    let genDep (dep, False {- not an hi file -}) =
 366           hPutStrLn hdl (unwords objs ++ " : " ++ dep)
 367        genDep (dep, True  {- is an hi file -}) = do
 368           hisuf <- readIORef v_Hi_suf
 369           let dep_base = remove_suffix '.' dep
 370               deps = (dep_base ++ hisuf)
 371                      : map (\suf -> dep_base ++ suf ++ '_':hisuf) extra_suffixes
 372                   -- length objs should be == length deps
 373           sequence_ (zipWith (\o d -> hPutStrLn hdl (o ++ " : " ++ d)) objs deps)
 374
 375    mapM genDep [ d | Just d <- deps ]
 376
 377    return True
 378
 379 -- add the lines to dep_makefile:
 380            -- always:
 381                    -- this.o : this.hs
 382
 383            -- if the dependency is on something other than a .hi file:
 384                    -- this.o this.p_o ... : dep
 385            -- otherwise
 386                    -- if the import is {-# SOURCE #-}
 387                            -- this.o this.p_o ... : dep.hi-boot[-$vers]
 388
 389                    -- else
 390                            -- this.o ...   : dep.hi
 391                            -- this.p_o ... : dep.p_hi
 392                            -- ...
 393
 394            -- (where .o is $osuf, and the other suffixes come from
 395            -- the cmdline -s options).
 396
 397 -----------------------------------------------------------------------------
 398 -- Hsc phase
 399
 400 -- Compilation of a single module, in "legacy" mode (_not_ under
 401 -- the direction of the compilation manager).
 402 run_phase Hsc basename suff input_fn output_fn
 403   = do
 404
 405   -- we add the current directory (i.e. the directory in which
 406   -- the .hs files resides) to the import path, since this is
 407   -- what gcc does, and it's probably what you want.
 408         let current_dir = getdir basename
 409
 410         paths <- readIORef v_Include_paths
 411         writeIORef v_Include_paths (current_dir : paths)
 412
 413   -- figure out where to put the .hi file
 414         ohi    <- readIORef v_Output_hi
 415         hisuf  <- readIORef v_Hi_suf
 416         let hifile = case ohi of
 417                            Nothing -> current_dir ++ "/" ++ basename
 418                                         ++ "." ++ hisuf
 419                            Just fn -> fn
 420
 421   -- figure out if the source has changed, for recompilation avoidance.
 422   -- only do this if we're eventually going to generate a .o file.
 423   -- (ToDo: do when generating .hc files too?)
 424   --
 425   -- Setting source_unchanged to True means that M.o seems
 426   -- to be up to date wrt M.hs; so no need to recompile unless imports have
 427   -- changed (which the compiler itself figures out).
 428   -- Setting source_unchanged to False tells the compiler that M.o is out of
 429   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
 430         do_recomp <- readIORef v_Recomp
 431         todo <- readIORef v_GhcMode
 432         o_file <- odir_ify (basename ++ '.':phaseInputExt Ln)
 433         source_unchanged <-
 434           if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
 435              then return False
 436              else do t1 <- getModificationTime (basename ++ '.':suff)
 437                      o_file_exists <- doesFileExist o_file
 438                      if not o_file_exists
 439                         then return False       -- Need to recompile
 440                         else do t2 <- getModificationTime o_file
 441                                 if t2 > t1
 442                                   then return True
 443                                   else return False
 444
 445    -- build a ModuleLocation to pass to hscMain.
 446         let location = ModuleLocation {
 447                           ml_hs_file   = Nothing,
 448                           ml_hspp_file = Just input_fn,
 449                           ml_hi_file   = Just hifile,
 450                           ml_obj_file  = Just o_file
 451                        }
 452
 453   -- get the DynFlags
 454         dyn_flags <- readIORef v_DynFlags
 455
 456   -- run the compiler!
 457         pcs <- initPersistentCompilerState
 458         result <- hscMain dyn_flags{ hscOutName = output_fn }
 459                           source_unchanged
 460                           location
 461                           Nothing        -- no iface
 462                           emptyModuleEnv -- HomeSymbolTable
 463                           emptyModuleEnv -- HomeIfaceTable
 464                           pcs
 465
 466         case result of {
 467
 468             HscFail pcs -> throwDyn (PhaseFailed "hsc" (ExitFailure 1));
 469
 470             HscOK details maybe_iface maybe_stub_h maybe_stub_c
 471                         _maybe_interpreted_code pcs -> do
 472
 473             -- deal with stubs
 474         maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
 475         case maybe_stub_o of
 476                 Nothing -> return ()
 477                 Just stub_o -> add v_Ld_inputs stub_o
 478
 479         let keep_going = case maybe_iface of Just _ -> True; Nothing -> False
 480         return keep_going
 481     }
 482
 483 -----------------------------------------------------------------------------
 484 -- Cc phase
 485
 486 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 487 -- way too many hacks, and I can't say I've ever used it anyway.
 488
 489 run_phase cc_phase _basename _suff input_fn output_fn
 490    | cc_phase == Cc || cc_phase == HCc
 491    = do cc <- readIORef v_Pgm_c
 492         cc_opts <- (getOpts opt_c)
 493         cmdline_include_dirs <- readIORef v_Include_paths
 494
 495         let hcc = cc_phase == HCc
 496
 497                 -- add package include paths even if we're just compiling
 498                 -- .c files; this is the Value Add(TM) that using
 499                 -- ghc instead of gcc gives you :)
 500         pkg_include_dirs <- getPackageIncludePath
 501         let include_paths = map (\p -> "-I"++p) (cmdline_include_dirs
 502                                                         ++ pkg_include_dirs)
 503
 504         c_includes <- getPackageCIncludes
 505         cmdline_includes <- readState cmdline_hc_includes -- -#include options
 506
 507         let cc_injects | hcc = unlines (map mk_include
 508                                         (c_includes ++ reverse cmdline_includes))
 509                        | otherwise = ""
 510             mk_include h_file =
 511                 case h_file of
 512                    '"':_{-"-} -> "#include "++h_file
 513                    '<':_      -> "#include "++h_file
 514                    _          -> "#include \""++h_file++"\""
 515
 516         cc_help <- newTempName "c"
 517         h <- openFile cc_help WriteMode
 518         hPutStr h cc_injects
 519         hPutStrLn h ("#include \"" ++ input_fn ++ "\"\n")
 520         hClose h
 521
 522         ccout <- newTempName "ccout"
 523
 524         mangle <- readIORef v_Do_asm_mangling
 525         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
 526
 527         verb <- is_verbose
 528
 529         o2 <- readIORef v_minus_o2_for_C
 530         let opt_flag | o2        = "-O2"
 531                      | otherwise = "-O"
 532
 533         pkg_extra_cc_opts <- getPackageExtraCcOpts
 534
 535         split_objs <- readIORef v_Split_object_files
 536         let split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
 537                       | otherwise         = [ ]
 538
 539         excessPrecision <- readIORef v_Excess_precision
 540
 541         run_something "C Compiler"
 542          (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
 543                    ++ md_c_flags
 544                    ++ (if cc_phase == HCc && mangle
 545                          then md_regd_c_flags
 546                          else [])
 547                    ++ [ verb, "-S", "-Wimplicit", opt_flag ]
 548                    ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 549                    ++ cc_opts
 550                    ++ split_opt
 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 v_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 v_Pgm_s
 587
 588         -- this is the prefix used for the split .s files
 589         tmp_pfx <- readIORef v_TmpDir
 590         x <- myGetProcessID
 591         let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
 592         writeIORef v_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 v_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 v_Pgm_a
 616         as_opts <- getOpts opt_a
 617
 618         cmdline_include_paths <- readIORef v_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 v_Pgm_a
 629         as_opts <- getOpts opt_a
 630
 631         split_s_prefix <- readIORef v_Split_prefix
 632         n <- readIORef v_N_split_files
 633
 634         odir <- readIORef v_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 v_Pgm_l
 658     verb <- is_verbose
 659     static <- readIORef v_Static
 660     let imp = if static then "" else "_imp"
 661     no_hs_main <- readIORef v_NoHsMain
 662
 663     o_file <- readIORef v_Output_file
 664     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
 665
 666     pkg_lib_paths <- getPackageLibraryPath
 667     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
 668
 669     lib_paths <- readIORef v_Library_paths
 670     let lib_path_opts = map ("-L"++) lib_paths
 671
 672     pkg_libs <- getPackageLibraries
 673     let pkg_lib_opts = map (\lib -> "-l" ++ lib ++ imp) pkg_libs
 674
 675     libs <- readIORef v_Cmdline_libraries
 676     let lib_opts = map ("-l"++) (reverse libs)
 677          -- reverse because they're added in reverse order from the cmd line
 678
 679     pkg_extra_ld_opts <- getPackageExtraLdOpts
 680
 681         -- probably _stub.o files
 682     extra_ld_inputs <- readIORef v_Ld_inputs
 683
 684         -- opts from -optl-<blah>
 685     extra_ld_opts <- getStaticOpts v_Opt_l
 686
 687     rts_pkg <- getPackageDetails ["rts"]
 688     std_pkg <- getPackageDetails ["std"]
 689 #ifdef mingw32_TARGET_OS
 690     let extra_os = if static || no_hs_main
 691                    then []
 692                    else [ head (library_dirs (head rts_pkg)) ++ "/Main.dll_o",
 693                           head (library_dirs (head std_pkg)) ++ "/PrelMain.dll_o" ]
 694 #endif
 695     (md_c_flags, _) <- machdepCCOpts
 696     run_something "Linker"
 697        (unwords
 698          ([ ln, verb, "-o", output_fn ]
 699          ++ md_c_flags
 700          ++ o_files
 701 #ifdef mingw32_TARGET_OS
 702          ++ extra_os
 703 #endif
 704          ++ extra_ld_inputs
 705          ++ lib_path_opts
 706          ++ lib_opts
 707          ++ pkg_lib_path_opts
 708          ++ pkg_lib_opts
 709          ++ pkg_extra_ld_opts
 710          ++ extra_ld_opts
 711 #ifdef mingw32_TARGET_OS
 712          ++ if static then [ "-u _PrelMain_mainIO_closure" , "-u ___init_PrelMain"] else []
 713 #else
 714          ++ [ "-u PrelMain_mainIO_closure" , "-u __init_PrelMain"]
 715 #endif
 716         )
 717        )
 718
 719 -----------------------------------------------------------------------------
 720 -- Just preprocess a file, put the result in a temp. file (used by the
 721 -- compilation manager during the summary phase).
 722
 723 preprocess :: FilePath -> IO FilePath
 724 preprocess filename =
 725   ASSERT(haskellish_file filename)
 726   do pipeline <- genPipeline (StopBefore Hsc) ("preprocess") filename
 727      runPipeline pipeline filename False{-no linking-} False{-no -o flag-}
 728
 729
 730 -----------------------------------------------------------------------------
 731 -- Compile a single module, under the control of the compilation manager.
 732 --
 733 -- This is the interface between the compilation manager and the
 734 -- compiler proper (hsc), where we deal with tedious details like
 735 -- reading the OPTIONS pragma from the source file, and passing the
 736 -- output of hsc through the C compiler.
 737
 738 -- The driver sits between 'compile' and 'hscMain', translating calls
 739 -- to the former into calls to the latter, and results from the latter
 740 -- into results from the former.  It does things like preprocessing
 741 -- the .hs file if necessary, and compiling up the .stub_c files to
 742 -- generate Linkables.
 743
 744 compile :: ModSummary              -- summary, including source
 745         -> Maybe ModIface          -- old interface, if available
 746         -> HomeSymbolTable         -- for home module ModDetails
 747         -> HomeIfaceTable          -- for home module Ifaces
 748         -> PersistentCompilerState -- persistent compiler state
 749         -> IO CompResult
 750
 751 data CompResult
 752    = CompOK   ModDetails  -- new details (HST additions)
 753               (Maybe (ModIface, Linkable))
 754                        -- summary and code; Nothing => compilation not reqd
 755                        -- (old summary and code are still valid)
 756               PersistentCompilerState   -- updated PCS
 757
 758    | CompErrs PersistentCompilerState   -- updated PCS
 759
 760
 761 compile summary old_iface hst hit pcs = do
 762    verb <- readIORef v_Verbose
 763    when verb (hPutStrLn stderr
 764                  (showSDoc (text "compile: compiling"
 765                             <+> ppr (name_of_summary summary))))
 766
 767    init_dyn_flags <- readIORef v_InitDynFlags
 768    writeIORef v_DynFlags init_dyn_flags
 769
 770    let location = ms_location summary
 771    let input_fn = unJust (ml_hs_file location) "compile:hs"
 772
 773    when verb (hPutStrLn stderr ("compile: input file " ++ input_fn))
 774
 775    opts <- getOptionsFromSource input_fn
 776    processArgs dynamic_flags opts []
 777    dyn_flags <- readIORef v_DynFlags
 778
 779    hsc_lang <- readIORef v_Hsc_Lang
 780    output_fn <- case hsc_lang of
 781                     HscAsm         -> newTempName (phaseInputExt As)
 782                     HscC           -> newTempName (phaseInputExt HCc)
 783                     HscJava        -> newTempName "java" -- ToDo
 784                     HscInterpreted -> return (error "no output file")
 785
 786    -- run the compiler
 787    hsc_result <- hscMain dyn_flags{ hscOutName = output_fn }
 788                          (panic "compile:source_unchanged")
 789                          location old_iface hst hit pcs
 790
 791    case hsc_result of {
 792       HscFail pcs -> return (CompErrs pcs);
 793
 794       HscOK details maybe_iface
 795         maybe_stub_h maybe_stub_c maybe_interpreted_code pcs -> do
 796
 797            -- if no compilation happened, bail out early
 798            case maybe_iface of {
 799                 Nothing -> return (CompOK details Nothing pcs);
 800                 Just iface -> do
 801
 802            let (basename, _) = splitFilename input_fn
 803            maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
 804            let stub_unlinked = case maybe_stub_o of
 805                                   Nothing -> []
 806                                   Just stub_o -> [ DotO stub_o ]
 807
 808            hs_unlinked <-
 809              case hsc_lang of
 810
 811                 -- in interpreted mode, just return the compiled code
 812                 -- as our "unlinked" object.
 813                 HscInterpreted ->
 814                     case maybe_interpreted_code of
 815                         Just (code,itbl_env) -> return [Trees code itbl_env]
 816                         Nothing -> panic "compile: no interpreted code"
 817
 818                 -- we're in batch mode: finish the compilation pipeline.
 819                 _other -> do pipe <- genPipeline (StopBefore Ln) "" output_fn
 820                              o_file <- runPipeline pipe output_fn False False
 821                              return [ DotO o_file ]
 822
 823            let linkable = LM (moduleName (ms_mod summary))
 824                                 (hs_unlinked ++ stub_unlinked)
 825
 826            return (CompOK details (Just (iface, linkable)) pcs)
 827           }
 828    }
 829
 830 -----------------------------------------------------------------------------
 831 -- stub .h and .c files (for foreign export support)
 832
 833 dealWithStubs basename maybe_stub_h maybe_stub_c
 834
 835  = do   let stub_h = basename ++ "_stub.h"
 836         let stub_c = basename ++ "_stub.c"
 837
 838   -- copy the .stub_h file into the current dir if necessary
 839         case maybe_stub_h of
 840            Nothing -> return ()
 841            Just tmp_stub_h -> do
 842                 run_something "Copy stub .h file"
 843                                 ("cp " ++ tmp_stub_h ++ ' ':stub_h)
 844
 845                         -- #include <..._stub.h> in .hc file
 846                 addCmdlineHCInclude tmp_stub_h  -- hack
 847
 848   -- copy the .stub_c file into the current dir, and compile it, if necessary
 849         case maybe_stub_c of
 850            Nothing -> return Nothing
 851            Just tmp_stub_c -> do  -- copy the _stub.c file into the current dir
 852                 run_something "Copy stub .c file"
 853                     (unwords [
 854                         "rm -f", stub_c, "&&",
 855                         "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
 856                         "cat", tmp_stub_c, ">> ", stub_c
 857                         ])
 858
 859                         -- compile the _stub.c file w/ gcc
 860                 pipeline <- genPipeline (StopBefore Ln) "" stub_c
 861                 stub_o <- runPipeline pipeline stub_c False{-no linking-}
 862                                 False{-no -o option-}
 863
 864                 return (Just stub_o)