ghc/compiler/main/DriverPipeline.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverPipeline.hs,v 1.32 2000/11/20 13:39:26 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 Time             ( getClockTime )
  43 import Directory
  44 import System
  45 import IOExts
  46 import Exception
  47
  48 import IO
  49 import Monad
  50 import Maybe
  51
  52 -----------------------------------------------------------------------------
  53 -- GHC modes of operation
  54
  55 data GhcMode
  56   = DoMkDependHS                        -- ghc -M
  57   | DoMkDLL                             -- ghc -mk-dll
  58   | StopBefore Phase                    -- ghc -E | -C | -S | -c
  59   | DoMake                              -- ghc --make
  60   | DoInteractive                       -- ghc --interactive
  61   | DoLink                              -- [ the default ]
  62   deriving (Eq)
  63
  64 GLOBAL_VAR(v_GhcMode, error "todo", GhcMode)
  65
  66 modeFlag :: String -> Maybe GhcMode
  67 modeFlag "-M"            = Just $ DoMkDependHS
  68 modeFlag "-E"            = Just $ StopBefore Hsc
  69 modeFlag "-C"            = Just $ StopBefore HCc
  70 modeFlag "-S"            = Just $ StopBefore As
  71 modeFlag "-c"            = Just $ StopBefore Ln
  72 modeFlag "--make"        = Just $ DoMake
  73 modeFlag "--interactive" = Just $ DoInteractive
  74 modeFlag _               = Nothing
  75
  76 getGhcMode :: [String]
  77          -> IO ( [String]   -- rest of command line
  78                , GhcMode
  79                , String     -- "GhcMode" flag
  80                )
  81 getGhcMode flags
  82   = case my_partition modeFlag flags of
  83         ([]   , rest) -> return (rest, DoLink,  "") -- default is to do linking
  84         ([(flag,one)], rest) -> return (rest, one, flag)
  85         (_    , _   ) ->
  86           throwDyn (OtherError
  87                 "only one of the flags -M, -E, -C, -S, -c, --make, --interactive is allowed")
  88
  89 -----------------------------------------------------------------------------
  90 -- genPipeline
  91 --
  92 -- Herein is all the magic about which phases to run in which order, whether
  93 -- the intermediate files should be in /tmp or in the current directory,
  94 -- what the suffix of the intermediate files should be, etc.
  95
  96 -- The following compilation pipeline algorithm is fairly hacky.  A
  97 -- better way to do this would be to express the whole comilation as a
  98 -- data flow DAG, where the nodes are the intermediate files and the
  99 -- edges are the compilation phases.  This framework would also work
 100 -- nicely if a haskell dependency generator was included in the
 101 -- driver.
 102
 103 -- It would also deal much more cleanly with compilation phases that
 104 -- generate multiple intermediates, (eg. hsc generates .hc, .hi, and
 105 -- possibly stub files), where some of the output files need to be
 106 -- processed further (eg. the stub files need to be compiled by the C
 107 -- compiler).
 108
 109 -- A cool thing to do would then be to execute the data flow graph
 110 -- concurrently, automatically taking advantage of extra processors on
 111 -- the host machine.  For example, when compiling two Haskell files
 112 -- where one depends on the other, the data flow graph would determine
 113 -- that the C compiler from the first comilation can be overlapped
 114 -- with the hsc comilation for the second file.
 115
 116 data IntermediateFileType
 117   = Temporary
 118   | Persistent
 119   deriving (Eq, Show)
 120
 121 genPipeline
 122    :: GhcMode           -- when to stop
 123    -> String            -- "stop after" flag (for error messages)
 124    -> Bool              -- True => output is persistent
 125    -> HscLang           -- preferred output language for hsc
 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 persistent_output lang filename
 134  = do
 135    split      <- readIORef v_Split_object_files
 136    mangle     <- readIORef v_Do_asm_mangling
 137    keep_hc    <- readIORef v_Keep_hc_files
 138    keep_raw_s <- readIORef v_Keep_raw_s_files
 139    keep_s     <- readIORef v_Keep_s_files
 140    osuf       <- readIORef v_Object_suf
 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 we need to force lang to HscC
 152     real_lang | start_phase == HCc  = HscC
 153               | otherwise           = lang
 154
 155    let
 156    ----------- -----  ----   ---   --   --  -  -  -
 157     pipeline
 158       | todo == DoMkDependHS = [ Unlit, Cpp, MkDependHS ]
 159
 160       | haskellish =
 161        case real_lang of
 162         HscC    | split && mangle -> [ Unlit, Cpp, Hsc, HCc, Mangle,
 163                                         SplitMangle, SplitAs ]
 164                 | mangle          -> [ Unlit, Cpp, Hsc, HCc, Mangle, As ]
 165                 | split           -> not_valid
 166                 | otherwise       -> [ Unlit, Cpp, Hsc, HCc, As ]
 167
 168         HscAsm  | split           -> [ Unlit, Cpp, Hsc, SplitMangle, SplitAs ]
 169                 | otherwise       -> [ Unlit, Cpp, Hsc, As ]
 170
 171         HscJava | split           -> not_valid
 172                 | otherwise       -> error "not implemented: compiling via Java"
 173
 174       | cish      = [ Cc, As ]
 175
 176       | otherwise = [ ]  -- just pass this file through to the linker
 177
 178         -- ToDo: this is somewhat cryptic
 179     not_valid = throwDyn (OtherError ("invalid option combination"))
 180    ----------- -----  ----   ---   --   --  -  -  -
 181
 182         -- this shouldn't happen.
 183    if start_phase /= Ln && start_phase `notElem` pipeline
 184         then throwDyn (OtherError ("can't find starting phase for "
 185                                     ++ filename))
 186         else do
 187
 188         -- if we can't find the phase we're supposed to stop before,
 189         -- something has gone wrong.
 190    case todo of
 191         StopBefore phase ->
 192            when (phase /= Ln
 193                  && phase `notElem` pipeline
 194                  && not (phase == As && SplitAs `elem` pipeline)) $
 195               throwDyn (OtherError
 196                 ("flag " ++ stop_flag
 197                  ++ " is incompatible with source file `" ++ filename ++ "'"))
 198         _ -> return ()
 199
 200    let
 201    ----------- -----  ----   ---   --   --  -  -  -
 202       myPhaseInputExt Ln = case osuf of Nothing -> phaseInputExt Ln
 203                                         Just s  -> s
 204       myPhaseInputExt other = phaseInputExt other
 205
 206       annotatePipeline
 207          :: [Phase]             -- raw pipeline
 208          -> Phase               -- phase to stop before
 209          -> [(Phase, IntermediateFileType, String{-file extension-})]
 210       annotatePipeline []     _    = []
 211       annotatePipeline (Ln:_) _    = []
 212       annotatePipeline (phase:next_phase:ps) stop =
 213           (phase, keep_this_output, myPhaseInputExt next_phase)
 214              : annotatePipeline (next_phase:ps) stop
 215           where
 216                 keep_this_output
 217                      | next_phase == stop
 218                      = if persistent_output then Persistent else Temporary
 219                      | otherwise
 220                      = case next_phase of
 221                              Ln -> Persistent
 222                              Mangle | keep_raw_s -> Persistent
 223                              As     | keep_s     -> Persistent
 224                              HCc    | keep_hc    -> Persistent
 225                              _other              -> Temporary
 226
 227         -- add information about output files to the pipeline
 228         -- the suffix on an output file is determined by the next phase
 229         -- in the pipeline, so we add linking to the end of the pipeline
 230         -- to force the output from the final phase to be a .o file.
 231       stop_phase = case todo of StopBefore phase -> phase
 232                                 DoMkDependHS     -> Ln
 233                                 DoLink           -> Ln
 234       annotated_pipeline = annotatePipeline (pipeline ++ [ Ln ]) stop_phase
 235
 236       phase_ne p (p1,_,_) = (p1 /= p)
 237    ----------- -----  ----   ---   --   --  -  -  -
 238
 239    return $
 240      dropWhile (phase_ne start_phase) .
 241         foldr (\p ps -> if phase_ne stop_phase p then p:ps else [])  []
 242                 $ annotated_pipeline
 243
 244
 245 runPipeline
 246   :: [ (Phase, IntermediateFileType, String) ] -- phases to run
 247   -> String                     -- input file
 248   -> Bool                       -- doing linking afterward?
 249   -> Bool                       -- take into account -o when generating output?
 250   -> IO String                  -- return final filename
 251
 252 runPipeline pipeline input_fn do_linking use_ofile
 253   = pipeLoop pipeline input_fn do_linking use_ofile basename suffix
 254   where (basename, suffix) = splitFilename input_fn
 255
 256 pipeLoop [] input_fn _ _ _ _ = return input_fn
 257 pipeLoop ((phase, keep, o_suffix):phases)
 258         input_fn do_linking use_ofile orig_basename orig_suffix
 259   = do
 260
 261      output_fn <- outputFileName (null phases) keep o_suffix
 262
 263      carry_on <- run_phase phase orig_basename orig_suffix input_fn output_fn
 264         -- sometimes we bail out early, eg. when the compiler's recompilation
 265         -- checker has determined that recompilation isn't necessary.
 266      if not carry_on
 267         then do let (_,keep,final_suffix) = last phases
 268                 ofile <- outputFileName True keep final_suffix
 269                 return ofile
 270         else do -- carry on ...
 271
 272      pipeLoop phases output_fn do_linking use_ofile orig_basename orig_suffix
 273
 274   where
 275      outputFileName last_phase keep suffix
 276         = do o_file <- readIORef v_Output_file
 277              if last_phase && not do_linking && use_ofile && isJust o_file
 278                then case o_file of
 279                        Just s  -> return s
 280                        Nothing -> error "outputFileName"
 281                else if keep == Persistent
 282                            then odir_ify (orig_basename ++ '.':suffix)
 283                            else newTempName suffix
 284
 285 -------------------------------------------------------------------------------
 286 -- Unlit phase
 287
 288 run_phase Unlit _basename _suff input_fn output_fn
 289   = do unlit <- readIORef v_Pgm_L
 290        unlit_flags <- getOpts opt_L
 291        run_something "Literate pre-processor"
 292           ("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
 293            ++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
 294        return True
 295
 296 -------------------------------------------------------------------------------
 297 -- Cpp phase
 298
 299 run_phase Cpp basename suff input_fn output_fn
 300   = do src_opts <- getOptionsFromSource input_fn
 301        unhandled_flags <- processArgs dynamic_flags src_opts []
 302
 303        when (not (null unhandled_flags))
 304             (throwDyn (OtherError (
 305                           basename ++ "." ++ suff
 306                           ++ ": static flags are not allowed in {-# OPTIONS #-} pragmas:\n\t"
 307                           ++ unwords unhandled_flags)) (ExitFailure 1))
 308
 309        do_cpp <- readState cpp_flag
 310        if do_cpp
 311           then do
 312             cpp <- readIORef v_Pgm_P
 313             hscpp_opts <- getOpts opt_P
 314             hs_src_cpp_opts <- readIORef v_Hs_source_cpp_opts
 315
 316             cmdline_include_paths <- readIORef v_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 (import_sources, import_normals, module_name) = getImports src
 344
 345    deps_sources <- mapM (findDependency True basename)  import_sources
 346    deps_normals <- mapM (findDependency False basename) import_normals
 347    let deps = deps_sources ++ deps_normals
 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 -> basename ++ '.':hisuf
 418                            Just fn -> fn
 419
 420   -- figure out if the source has changed, for recompilation avoidance.
 421   -- only do this if we're eventually going to generate a .o file.
 422   -- (ToDo: do when generating .hc files too?)
 423   --
 424   -- Setting source_unchanged to True means that M.o seems
 425   -- to be up to date wrt M.hs; so no need to recompile unless imports have
 426   -- changed (which the compiler itself figures out).
 427   -- Setting source_unchanged to False tells the compiler that M.o is out of
 428   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
 429         do_recomp <- readIORef v_Recomp
 430         todo <- readIORef v_GhcMode
 431         o_file <- odir_ify (basename ++ '.':phaseInputExt Ln)
 432         source_unchanged <-
 433           if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
 434              then return False
 435              else do t1 <- getModificationTime (basename ++ '.':suff)
 436                      o_file_exists <- doesFileExist o_file
 437                      if not o_file_exists
 438                         then return False       -- Need to recompile
 439                         else do t2 <- getModificationTime o_file
 440                                 if t2 > t1
 441                                   then return True
 442                                   else return False
 443
 444    -- build a ModuleLocation to pass to hscMain.
 445         let location = ModuleLocation {
 446                           ml_hs_file   = Nothing,
 447                           ml_hspp_file = Just input_fn,
 448                           ml_hi_file   = Just hifile,
 449                           ml_obj_file  = Just o_file
 450                        }
 451
 452   -- get the DynFlags
 453         dyn_flags <- readIORef v_DynFlags
 454
 455   -- run the compiler!
 456         pcs <- initPersistentCompilerState
 457         result <- hscMain OneShot
 458                           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 (lib_paths (head rts_pkg)) ++ "/Main.dll_o",
 693 --                          head (lib_paths (head std_pkg)) ++ "/PrelMain.dll_o" ]
 694                      else []
 695 #endif
 696     (md_c_flags, _) <- machdepCCOpts
 697     run_something "Linker"
 698        (unwords
 699          ([ ln, verb, "-o", output_fn ]
 700          ++ md_c_flags
 701          ++ o_files
 702 #ifdef mingw32_TARGET_OS
 703          ++ extra_os
 704 #endif
 705          ++ extra_ld_inputs
 706          ++ lib_path_opts
 707          ++ lib_opts
 708          ++ pkg_lib_path_opts
 709          ++ pkg_lib_opts
 710          ++ pkg_extra_ld_opts
 711          ++ extra_ld_opts
 712 #ifdef mingw32_TARGET_OS
 713          ++ if static then [ "-u _PrelMain_mainIO_closure" , "-u ___init_PrelMain"] else []
 714 #else
 715          ++ [ "-u PrelMain_mainIO_closure" , "-u __init_PrelMain"]
 716 #endif
 717         )
 718        )
 719
 720 -----------------------------------------------------------------------------
 721 -- Just preprocess a file, put the result in a temp. file (used by the
 722 -- compilation manager during the summary phase).
 723
 724 preprocess :: FilePath -> IO FilePath
 725 preprocess filename =
 726   ASSERT(haskellish_file filename)
 727   do init_driver_state <- readIORef v_InitDriverState
 728      writeIORef v_Driver_state init_driver_state
 729
 730      pipeline <- genPipeline (StopBefore Hsc) ("preprocess") False
 731                         defaultHscLang filename
 732      runPipeline pipeline filename False{-no linking-} False{-no -o flag-}
 733
 734
 735 -----------------------------------------------------------------------------
 736 -- Compile a single module, under the control of the compilation manager.
 737 --
 738 -- This is the interface between the compilation manager and the
 739 -- compiler proper (hsc), where we deal with tedious details like
 740 -- reading the OPTIONS pragma from the source file, and passing the
 741 -- output of hsc through the C compiler.
 742
 743 -- The driver sits between 'compile' and 'hscMain', translating calls
 744 -- to the former into calls to the latter, and results from the latter
 745 -- into results from the former.  It does things like preprocessing
 746 -- the .hs file if necessary, and compiling up the .stub_c files to
 747 -- generate Linkables.
 748
 749 -- NB.  No old interface can also mean that the source has changed.
 750
 751 compile :: GhciMode                -- distinguish batch from interactive
 752         -> ModSummary              -- summary, including source
 753         -> Bool                    -- source unchanged?
 754         -> Maybe ModIface          -- old interface, if available
 755         -> HomeSymbolTable         -- for home module ModDetails
 756         -> HomeIfaceTable          -- for home module Ifaces
 757         -> PersistentCompilerState -- persistent compiler state
 758         -> IO CompResult
 759
 760 data CompResult
 761    = CompOK   ModDetails  -- new details (HST additions)
 762               (Maybe (ModIface, Linkable))
 763                        -- summary and code; Nothing => compilation not reqd
 764                        -- (old summary and code are still valid)
 765               PersistentCompilerState   -- updated PCS
 766
 767    | CompErrs PersistentCompilerState   -- updated PCS
 768
 769
 770 compile ghci_mode summary source_unchanged old_iface hst hit pcs = do
 771    verb <- readIORef v_Verbose
 772    when verb (hPutStrLn stderr
 773                  (showSDoc (text "compile: compiling"
 774                             <+> ppr (name_of_summary summary))))
 775
 776    init_dyn_flags <- readIORef v_InitDynFlags
 777    writeIORef v_DynFlags init_dyn_flags
 778    init_driver_state <- readIORef v_InitDriverState
 779    writeIORef v_Driver_state init_driver_state
 780
 781    let location   = ms_location summary
 782    let input_fn   = unJust "compile:hs" (ml_hs_file location)
 783    let input_fnpp = unJust "compile:hspp" (ml_hspp_file location)
 784
 785    when verb (hPutStrLn stderr ("compile: input file " ++ input_fnpp))
 786
 787    opts <- getOptionsFromSource input_fnpp
 788    processArgs dynamic_flags opts []
 789    dyn_flags <- readIORef v_DynFlags
 790
 791    let hsc_lang = hscLang dyn_flags
 792    output_fn <- case hsc_lang of
 793                     HscAsm         -> newTempName (phaseInputExt As)
 794                     HscC           -> newTempName (phaseInputExt HCc)
 795                     HscJava        -> newTempName "java" -- ToDo
 796                     HscInterpreted -> return (error "no output file")
 797
 798    -- run the compiler
 799    hsc_result <- hscMain ghci_mode dyn_flags{ hscOutName = output_fn }
 800                          source_unchanged
 801                          location old_iface hst hit pcs
 802
 803    case hsc_result of {
 804       HscFail pcs -> return (CompErrs pcs);
 805
 806       HscOK details maybe_iface
 807         maybe_stub_h maybe_stub_c maybe_interpreted_code pcs -> do
 808
 809            -- if no compilation happened, bail out early
 810            case maybe_iface of {
 811                 Nothing -> return (CompOK details Nothing pcs);
 812                 Just iface -> do
 813
 814            let (basename, _) = splitFilename input_fn
 815            maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
 816            let stub_unlinked = case maybe_stub_o of
 817                                   Nothing -> []
 818                                   Just stub_o -> [ DotO stub_o ]
 819
 820            (hs_unlinked, unlinked_time) <-
 821              case hsc_lang of
 822
 823                 -- in interpreted mode, just return the compiled code
 824                 -- as our "unlinked" object.
 825                 HscInterpreted ->
 826                     case maybe_interpreted_code of
 827                        Just (code,itbl_env) -> do tm <- getClockTime
 828                                                   return ([Trees code itbl_env], tm)
 829                        Nothing -> panic "compile: no interpreted code"
 830
 831                 -- we're in batch mode: finish the compilation pipeline.
 832                 _other -> do pipe <- genPipeline (StopBefore Ln) "" True
 833                                         hsc_lang output_fn
 834                              -- runPipeline takes input_fn so it can split off
 835                              -- the base name and use it as the base of
 836                              -- the output object file.
 837                              let (basename, suffix) = splitFilename input_fn
 838                              o_file <- pipeLoop pipe output_fn False False
 839                                                 basename suffix
 840                              o_time <- getModificationTime o_file
 841                              return ([DotO o_file], o_time)
 842
 843            let linkable = LM unlinked_time (moduleName (ms_mod summary))
 844                              (hs_unlinked ++ stub_unlinked)
 845
 846            return (CompOK details (Just (iface, linkable)) pcs)
 847           }
 848    }
 849
 850 -----------------------------------------------------------------------------
 851 -- stub .h and .c files (for foreign export support)
 852
 853 dealWithStubs basename maybe_stub_h maybe_stub_c
 854
 855  = do   let stub_h = basename ++ "_stub.h"
 856         let stub_c = basename ++ "_stub.c"
 857
 858   -- copy the .stub_h file into the current dir if necessary
 859         case maybe_stub_h of
 860            Nothing -> return ()
 861            Just tmp_stub_h -> do
 862                 run_something "Copy stub .h file"
 863                                 ("cp " ++ tmp_stub_h ++ ' ':stub_h)
 864
 865                         -- #include <..._stub.h> in .hc file
 866                 addCmdlineHCInclude tmp_stub_h  -- hack
 867
 868   -- copy the .stub_c file into the current dir, and compile it, if necessary
 869         case maybe_stub_c of
 870            Nothing -> return Nothing
 871            Just tmp_stub_c -> do  -- copy the _stub.c file into the current dir
 872                 run_something "Copy stub .c file"
 873                     (unwords [
 874                         "rm -f", stub_c, "&&",
 875                         "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
 876                         "cat", tmp_stub_c, ">> ", stub_c
 877                         ])
 878
 879                         -- compile the _stub.c file w/ gcc
 880                 pipeline <- genPipeline (StopBefore Ln) "" True
 881                                 defaultHscLang stub_c
 882                 stub_o <- runPipeline pipeline stub_c False{-no linking-}
 883                                 False{-no -o option-}
 884
 885                 return (Just stub_o)