ghc/compiler/main/DriverPipeline.hs

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