ghc/compiler/main/DriverPipeline.hs

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