ghc/compiler/main/DriverPipeline.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverPipeline.hs,v 1.16 2000/11/08 15:25:25 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         excessPrecision <- readIORef v_Excess_precision
 536
 537         run_something "C Compiler"
 538          (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
 539                    ++ md_c_flags
 540                    ++ (if cc_phase == HCc && mangle
 541                          then md_regd_c_flags
 542                          else [])
 543                    ++ [ verb, "-S", "-Wimplicit", opt_flag ]
 544                    ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 545                    ++ cc_opts
 546 #ifdef mingw32_TARGET_OS
 547                    ++ [" -mno-cygwin"]
 548 #endif
 549                    ++ (if excessPrecision then [] else [ "-ffloat-store" ])
 550                    ++ include_paths
 551                    ++ pkg_extra_cc_opts
 552 --                 ++ [">", ccout]
 553                    ))
 554         return True
 555
 556         -- ToDo: postprocess the output from gcc
 557
 558 -----------------------------------------------------------------------------
 559 -- Mangle phase
 560
 561 run_phase Mangle _basename _suff input_fn output_fn
 562   = do mangler <- readIORef v_Pgm_m
 563        mangler_opts <- getOpts opt_m
 564        machdep_opts <-
 565          if (prefixMatch "i386" cTARGETPLATFORM)
 566             then do n_regs <- readState stolen_x86_regs
 567                     return [ show n_regs ]
 568             else return []
 569        run_something "Assembly Mangler"
 570         (unwords (mangler :
 571                      mangler_opts
 572                   ++ [ input_fn, output_fn ]
 573                   ++ machdep_opts
 574                 ))
 575        return True
 576
 577 -----------------------------------------------------------------------------
 578 -- Splitting phase
 579
 580 run_phase SplitMangle _basename _suff input_fn _output_fn
 581   = do  splitter <- readIORef v_Pgm_s
 582
 583         -- this is the prefix used for the split .s files
 584         tmp_pfx <- readIORef v_TmpDir
 585         x <- myGetProcessID
 586         let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
 587         writeIORef v_Split_prefix split_s_prefix
 588         addFilesToClean [split_s_prefix ++ "__*"] -- d:-)
 589
 590         -- allocate a tmp file to put the no. of split .s files in (sigh)
 591         n_files <- newTempName "n_files"
 592
 593         run_something "Split Assembly File"
 594          (unwords [ splitter
 595                   , input_fn
 596                   , split_s_prefix
 597                   , n_files ]
 598          )
 599
 600         -- save the number of split files for future references
 601         s <- readFile n_files
 602         let n = read s :: Int
 603         writeIORef v_N_split_files n
 604         return True
 605
 606 -----------------------------------------------------------------------------
 607 -- As phase
 608
 609 run_phase As _basename _suff input_fn output_fn
 610   = do  as <- readIORef v_Pgm_a
 611         as_opts <- getOpts opt_a
 612
 613         cmdline_include_paths <- readIORef v_Include_paths
 614         let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
 615         run_something "Assembler"
 616            (unwords (as : as_opts
 617                        ++ cmdline_include_flags
 618                        ++ [ "-c", input_fn, "-o",  output_fn ]
 619                     ))
 620         return True
 621
 622 run_phase SplitAs basename _suff _input_fn _output_fn
 623   = do  as <- readIORef v_Pgm_a
 624         as_opts <- getOpts opt_a
 625
 626         split_s_prefix <- readIORef v_Split_prefix
 627         n <- readIORef v_N_split_files
 628
 629         odir <- readIORef v_Output_dir
 630         let real_odir = case odir of
 631                                 Nothing -> basename
 632                                 Just d  -> d
 633
 634         let assemble_file n = do
 635                     let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
 636                     let output_o = newdir real_odir
 637                                         (basename ++ "__" ++ show n ++ ".o")
 638                     real_o <- osuf_ify output_o
 639                     run_something "Assembler"
 640                             (unwords (as : as_opts
 641                                       ++ [ "-c", "-o", real_o, input_s ]
 642                             ))
 643
 644         mapM_ assemble_file [1..n]
 645         return True
 646
 647 -----------------------------------------------------------------------------
 648 -- Linking
 649
 650 doLink :: [String] -> IO ()
 651 doLink o_files = do
 652     ln <- readIORef v_Pgm_l
 653     verb <- is_verbose
 654     o_file <- readIORef v_Output_file
 655     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
 656
 657     pkg_lib_paths <- getPackageLibraryPath
 658     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
 659
 660     lib_paths <- readIORef v_Library_paths
 661     let lib_path_opts = map ("-L"++) lib_paths
 662
 663     pkg_libs <- getPackageLibraries
 664     let pkg_lib_opts = map (\lib -> "-l"++lib) pkg_libs
 665
 666     libs <- readIORef v_Cmdline_libraries
 667     let lib_opts = map ("-l"++) (reverse libs)
 668          -- reverse because they're added in reverse order from the cmd line
 669
 670     pkg_extra_ld_opts <- getPackageExtraLdOpts
 671
 672         -- probably _stub.o files
 673     extra_ld_inputs <- readIORef v_Ld_inputs
 674
 675         -- opts from -optl-<blah>
 676     extra_ld_opts <- getStaticOpts v_Opt_l
 677
 678     run_something "Linker"
 679        (unwords
 680          ([ ln, verb, "-o", output_fn ]
 681          ++ o_files
 682          ++ extra_ld_inputs
 683          ++ lib_path_opts
 684          ++ lib_opts
 685          ++ pkg_lib_path_opts
 686          ++ pkg_lib_opts
 687          ++ pkg_extra_ld_opts
 688          ++ extra_ld_opts
 689         )
 690        )
 691
 692 -----------------------------------------------------------------------------
 693 -- Just preprocess a file, put the result in a temp. file (used by the
 694 -- compilation manager during the summary phase).
 695
 696 preprocess :: FilePath -> IO FilePath
 697 preprocess filename =
 698   ASSERT(haskellish_file filename)
 699   do pipeline <- genPipeline (StopBefore Hsc) ("preprocess") filename
 700      runPipeline pipeline filename False{-no linking-} False{-no -o flag-}
 701
 702
 703 -----------------------------------------------------------------------------
 704 -- Compile a single module, under the control of the compilation manager.
 705 --
 706 -- This is the interface between the compilation manager and the
 707 -- compiler proper (hsc), where we deal with tedious details like
 708 -- reading the OPTIONS pragma from the source file, and passing the
 709 -- output of hsc through the C compiler.
 710
 711 -- The driver sits between 'compile' and 'hscMain', translating calls
 712 -- to the former into calls to the latter, and results from the latter
 713 -- into results from the former.  It does things like preprocessing
 714 -- the .hs file if necessary, and compiling up the .stub_c files to
 715 -- generate Linkables.
 716
 717 compile :: ModSummary              -- summary, including source
 718         -> Maybe ModIface          -- old interface, if available
 719         -> HomeSymbolTable         -- for home module ModDetails
 720         -> HomeIfaceTable          -- for home module Ifaces
 721         -> PersistentCompilerState -- persistent compiler state
 722         -> IO CompResult
 723
 724 data CompResult
 725    = CompOK   ModDetails  -- new details (HST additions)
 726               (Maybe (ModIface, Linkable))
 727                        -- summary and code; Nothing => compilation not reqd
 728                        -- (old summary and code are still valid)
 729               PersistentCompilerState   -- updated PCS
 730
 731    | CompErrs PersistentCompilerState   -- updated PCS
 732
 733
 734 compile summary old_iface hst hit pcs = do
 735    verb <- readIORef v_Verbose
 736    when verb (hPutStrLn stderr
 737                  (showSDoc (text "compile: compiling"
 738                             <+> ppr (name_of_summary summary))))
 739
 740    init_dyn_flags <- readIORef v_InitDynFlags
 741    writeIORef v_DynFlags init_dyn_flags
 742
 743    let location = ms_location summary
 744    let input_fn = unJust (ml_hs_file location) "compile:hs"
 745
 746    when verb (hPutStrLn stderr ("compile: input file " ++ input_fn))
 747
 748    opts <- getOptionsFromSource input_fn
 749    processArgs dynamic_flags opts []
 750    dyn_flags <- readIORef v_DynFlags
 751
 752    hsc_lang <- readIORef v_Hsc_Lang
 753    output_fn <- case hsc_lang of
 754                     HscAsm         -> newTempName (phaseInputExt As)
 755                     HscC           -> newTempName (phaseInputExt HCc)
 756                     HscJava        -> newTempName "java" -- ToDo
 757                     HscInterpreted -> return (error "no output file")
 758
 759    -- run the compiler
 760    hsc_result <- hscMain dyn_flags{ hscOutName = output_fn }
 761                          (panic "compile:source_unchanged")
 762                          location old_iface hst hit pcs
 763
 764    case hsc_result of {
 765       HscFail pcs -> return (CompErrs pcs);
 766
 767       HscOK details maybe_iface
 768         maybe_stub_h maybe_stub_c maybe_interpreted_code pcs -> do
 769
 770            -- if no compilation happened, bail out early
 771            case maybe_iface of {
 772                 Nothing -> return (CompOK details Nothing pcs);
 773                 Just iface -> do
 774
 775            let (basename, _) = splitFilename input_fn
 776            maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
 777            let stub_unlinked = case maybe_stub_o of
 778                                   Nothing -> []
 779                                   Just stub_o -> [ DotO stub_o ]
 780
 781            hs_unlinked <-
 782              case hsc_lang of
 783
 784                 -- in interpreted mode, just return the compiled code
 785                 -- as our "unlinked" object.
 786                 HscInterpreted ->
 787                     case maybe_interpreted_code of
 788                         Just (code,itbl_env) -> return [Trees code itbl_env]
 789                         Nothing -> panic "compile: no interpreted code"
 790
 791                 -- we're in batch mode: finish the compilation pipeline.
 792                 _other -> do pipe <- genPipeline (StopBefore Ln) "" output_fn
 793                              o_file <- runPipeline pipe output_fn False False
 794                              return [ DotO o_file ]
 795
 796            let linkable = LM (moduleName (ms_mod summary))
 797                                 (hs_unlinked ++ stub_unlinked)
 798
 799            return (CompOK details (Just (iface, linkable)) pcs)
 800           }
 801    }
 802
 803 -----------------------------------------------------------------------------
 804 -- stub .h and .c files (for foreign export support)
 805
 806 dealWithStubs basename maybe_stub_h maybe_stub_c
 807
 808  = do   let stub_h = basename ++ "_stub.h"
 809         let stub_c = basename ++ "_stub.c"
 810
 811   -- copy the .stub_h file into the current dir if necessary
 812         case maybe_stub_h of
 813            Nothing -> return ()
 814            Just tmp_stub_h -> do
 815                 run_something "Copy stub .h file"
 816                                 ("cp " ++ tmp_stub_h ++ ' ':stub_h)
 817
 818                         -- #include <..._stub.h> in .hc file
 819                 addCmdlineHCInclude tmp_stub_h  -- hack
 820
 821   -- copy the .stub_c file into the current dir, and compile it, if necessary
 822         case maybe_stub_c of
 823            Nothing -> return Nothing
 824            Just tmp_stub_c -> do  -- copy the _stub.c file into the current dir
 825                 run_something "Copy stub .c file"
 826                     (unwords [
 827                         "rm -f", stub_c, "&&",
 828                         "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
 829                         "cat", tmp_stub_c, ">> ", stub_c
 830                         ])
 831
 832                         -- compile the _stub.c file w/ gcc
 833                 pipeline <- genPipeline (StopBefore Ln) "" stub_c
 834                 stub_o <- runPipeline pipeline stub_c False{-no linking-}
 835                                 False{-no -o option-}
 836
 837                 return (Just stub_o)