ghc/compiler/main/DriverPipeline.hs

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