ghc/compiler/main/DriverPipeline.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverPipeline.hs,v 1.17 2000/11/08 16:24:34 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     o_file <- readIORef v_Output_file
 660     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
 661
 662     pkg_lib_paths <- getPackageLibraryPath
 663     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
 664
 665     lib_paths <- readIORef v_Library_paths
 666     let lib_path_opts = map ("-L"++) lib_paths
 667
 668     pkg_libs <- getPackageLibraries
 669     let pkg_lib_opts = map (\lib -> "-l"++lib) pkg_libs
 670
 671     libs <- readIORef v_Cmdline_libraries
 672     let lib_opts = map ("-l"++) (reverse libs)
 673          -- reverse because they're added in reverse order from the cmd line
 674
 675     pkg_extra_ld_opts <- getPackageExtraLdOpts
 676
 677         -- probably _stub.o files
 678     extra_ld_inputs <- readIORef v_Ld_inputs
 679
 680         -- opts from -optl-<blah>
 681     extra_ld_opts <- getStaticOpts v_Opt_l
 682
 683     run_something "Linker"
 684        (unwords
 685          ([ ln, verb, "-o", output_fn ]
 686          ++ o_files
 687          ++ extra_ld_inputs
 688          ++ lib_path_opts
 689          ++ lib_opts
 690          ++ pkg_lib_path_opts
 691          ++ pkg_lib_opts
 692          ++ pkg_extra_ld_opts
 693          ++ extra_ld_opts
 694         )
 695        )
 696
 697 -----------------------------------------------------------------------------
 698 -- Just preprocess a file, put the result in a temp. file (used by the
 699 -- compilation manager during the summary phase).
 700
 701 preprocess :: FilePath -> IO FilePath
 702 preprocess filename =
 703   ASSERT(haskellish_file filename)
 704   do pipeline <- genPipeline (StopBefore Hsc) ("preprocess") filename
 705      runPipeline pipeline filename False{-no linking-} False{-no -o flag-}
 706
 707
 708 -----------------------------------------------------------------------------
 709 -- Compile a single module, under the control of the compilation manager.
 710 --
 711 -- This is the interface between the compilation manager and the
 712 -- compiler proper (hsc), where we deal with tedious details like
 713 -- reading the OPTIONS pragma from the source file, and passing the
 714 -- output of hsc through the C compiler.
 715
 716 -- The driver sits between 'compile' and 'hscMain', translating calls
 717 -- to the former into calls to the latter, and results from the latter
 718 -- into results from the former.  It does things like preprocessing
 719 -- the .hs file if necessary, and compiling up the .stub_c files to
 720 -- generate Linkables.
 721
 722 compile :: ModSummary              -- summary, including source
 723         -> Maybe ModIface          -- old interface, if available
 724         -> HomeSymbolTable         -- for home module ModDetails
 725         -> HomeIfaceTable          -- for home module Ifaces
 726         -> PersistentCompilerState -- persistent compiler state
 727         -> IO CompResult
 728
 729 data CompResult
 730    = CompOK   ModDetails  -- new details (HST additions)
 731               (Maybe (ModIface, Linkable))
 732                        -- summary and code; Nothing => compilation not reqd
 733                        -- (old summary and code are still valid)
 734               PersistentCompilerState   -- updated PCS
 735
 736    | CompErrs PersistentCompilerState   -- updated PCS
 737
 738
 739 compile summary old_iface hst hit pcs = do
 740    verb <- readIORef v_Verbose
 741    when verb (hPutStrLn stderr
 742                  (showSDoc (text "compile: compiling"
 743                             <+> ppr (name_of_summary summary))))
 744
 745    init_dyn_flags <- readIORef v_InitDynFlags
 746    writeIORef v_DynFlags init_dyn_flags
 747
 748    let location = ms_location summary
 749    let input_fn = unJust (ml_hs_file location) "compile:hs"
 750
 751    when verb (hPutStrLn stderr ("compile: input file " ++ input_fn))
 752
 753    opts <- getOptionsFromSource input_fn
 754    processArgs dynamic_flags opts []
 755    dyn_flags <- readIORef v_DynFlags
 756
 757    hsc_lang <- readIORef v_Hsc_Lang
 758    output_fn <- case hsc_lang of
 759                     HscAsm         -> newTempName (phaseInputExt As)
 760                     HscC           -> newTempName (phaseInputExt HCc)
 761                     HscJava        -> newTempName "java" -- ToDo
 762                     HscInterpreted -> return (error "no output file")
 763
 764    -- run the compiler
 765    hsc_result <- hscMain dyn_flags{ hscOutName = output_fn }
 766                          (panic "compile:source_unchanged")
 767                          location old_iface hst hit pcs
 768
 769    case hsc_result of {
 770       HscFail pcs -> return (CompErrs pcs);
 771
 772       HscOK details maybe_iface
 773         maybe_stub_h maybe_stub_c maybe_interpreted_code pcs -> do
 774
 775            -- if no compilation happened, bail out early
 776            case maybe_iface of {
 777                 Nothing -> return (CompOK details Nothing pcs);
 778                 Just iface -> do
 779
 780            let (basename, _) = splitFilename input_fn
 781            maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
 782            let stub_unlinked = case maybe_stub_o of
 783                                   Nothing -> []
 784                                   Just stub_o -> [ DotO stub_o ]
 785
 786            hs_unlinked <-
 787              case hsc_lang of
 788
 789                 -- in interpreted mode, just return the compiled code
 790                 -- as our "unlinked" object.
 791                 HscInterpreted ->
 792                     case maybe_interpreted_code of
 793                         Just (code,itbl_env) -> return [Trees code itbl_env]
 794                         Nothing -> panic "compile: no interpreted code"
 795
 796                 -- we're in batch mode: finish the compilation pipeline.
 797                 _other -> do pipe <- genPipeline (StopBefore Ln) "" output_fn
 798                              o_file <- runPipeline pipe output_fn False False
 799                              return [ DotO o_file ]
 800
 801            let linkable = LM (moduleName (ms_mod summary))
 802                                 (hs_unlinked ++ stub_unlinked)
 803
 804            return (CompOK details (Just (iface, linkable)) pcs)
 805           }
 806    }
 807
 808 -----------------------------------------------------------------------------
 809 -- stub .h and .c files (for foreign export support)
 810
 811 dealWithStubs basename maybe_stub_h maybe_stub_c
 812
 813  = do   let stub_h = basename ++ "_stub.h"
 814         let stub_c = basename ++ "_stub.c"
 815
 816   -- copy the .stub_h file into the current dir if necessary
 817         case maybe_stub_h of
 818            Nothing -> return ()
 819            Just tmp_stub_h -> do
 820                 run_something "Copy stub .h file"
 821                                 ("cp " ++ tmp_stub_h ++ ' ':stub_h)
 822
 823                         -- #include <..._stub.h> in .hc file
 824                 addCmdlineHCInclude tmp_stub_h  -- hack
 825
 826   -- copy the .stub_c file into the current dir, and compile it, if necessary
 827         case maybe_stub_c of
 828            Nothing -> return Nothing
 829            Just tmp_stub_c -> do  -- copy the _stub.c file into the current dir
 830                 run_something "Copy stub .c file"
 831                     (unwords [
 832                         "rm -f", stub_c, "&&",
 833                         "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
 834                         "cat", tmp_stub_c, ">> ", stub_c
 835                         ])
 836
 837                         -- compile the _stub.c file w/ gcc
 838                 pipeline <- genPipeline (StopBefore Ln) "" stub_c
 839                 stub_o <- runPipeline pipeline stub_c False{-no linking-}
 840                                 False{-no -o option-}
 841
 842                 return (Just stub_o)