ghc/compiler/main/DriverPipeline.hs

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