ghc/compiler/main/DriverPipeline.hs

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