ghc/compiler/main/DriverPipeline.hs

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