ghc/compiler/main/DriverPipeline.hs

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