ghc/compiler/main/DriverPipeline.hs

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