ghc/compiler/main/DriverPipeline.hs

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