ghc/compiler/main/DriverPipeline.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverPipeline.hs,v 1.14 2000/10/31 13:01:46 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,
  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    -> String            -- original filename
 123    -> IO [              -- list of phases to run for this file
 124              (Phase,
 125               IntermediateFileType,  -- keep the output from this phase?
 126               String)                -- output file suffix
 127          ]
 128
 129 genPipeline todo stop_flag filename
 130  = do
 131    split      <- readIORef v_Split_object_files
 132    mangle     <- readIORef v_Do_asm_mangling
 133    lang       <- readIORef v_Hsc_Lang
 134    keep_hc    <- readIORef v_Keep_hc_files
 135    keep_raw_s <- readIORef v_Keep_raw_s_files
 136    keep_s     <- readIORef v_Keep_s_files
 137
 138    let
 139    ----------- -----  ----   ---   --   --  -  -  -
 140     (_basename, suffix) = splitFilename filename
 141
 142     start_phase = startPhase suffix
 143
 144     haskellish = haskellish_suffix suffix
 145     cish = cish_suffix suffix
 146
 147    -- for a .hc file, or if the -C flag is given, we need to force lang to HscC
 148     real_lang | suffix == "hc"  = HscC
 149               | otherwise       = lang
 150
 151    let
 152    ----------- -----  ----   ---   --   --  -  -  -
 153     pipeline
 154       | todo == DoMkDependHS = [ Unlit, Cpp, MkDependHS ]
 155
 156       | haskellish =
 157        case real_lang of
 158         HscC    | split && mangle -> [ Unlit, Cpp, Hsc, HCc, Mangle,
 159                                         SplitMangle, SplitAs ]
 160                 | mangle          -> [ Unlit, Cpp, Hsc, HCc, Mangle, As ]
 161                 | split           -> not_valid
 162                 | otherwise       -> [ Unlit, Cpp, Hsc, HCc, As ]
 163
 164         HscAsm  | split           -> [ Unlit, Cpp, Hsc, SplitMangle, SplitAs ]
 165                 | otherwise       -> [ Unlit, Cpp, Hsc, As ]
 166
 167         HscJava | split           -> not_valid
 168                 | otherwise       -> error "not implemented: compiling via Java"
 169
 170       | cish      = [ Cc, As ]
 171
 172       | otherwise = [ ]  -- just pass this file through to the linker
 173
 174         -- ToDo: this is somewhat cryptic
 175     not_valid = throwDyn (OtherError ("invalid option combination"))
 176    ----------- -----  ----   ---   --   --  -  -  -
 177
 178         -- this shouldn't happen.
 179    if start_phase /= Ln && start_phase `notElem` pipeline
 180         then throwDyn (OtherError ("can't find starting phase for "
 181                                     ++ filename))
 182         else do
 183
 184         -- if we can't find the phase we're supposed to stop before,
 185         -- something has gone wrong.
 186    case todo of
 187         StopBefore phase ->
 188            when (phase /= Ln
 189                  && phase `notElem` pipeline
 190                  && not (phase == As && SplitAs `elem` pipeline)) $
 191               throwDyn (OtherError
 192                 ("flag " ++ stop_flag
 193                  ++ " is incompatible with source file `" ++ filename ++ "'"))
 194         _ -> return ()
 195
 196    let
 197    ----------- -----  ----   ---   --   --  -  -  -
 198       annotatePipeline
 199          :: [Phase]             -- raw pipeline
 200          -> Phase               -- phase to stop before
 201          -> [(Phase, IntermediateFileType, String{-file extension-})]
 202       annotatePipeline []     _    = []
 203       annotatePipeline (Ln:_) _    = []
 204       annotatePipeline (phase:next_phase:ps) stop =
 205           (phase, keep_this_output, phaseInputExt next_phase)
 206              : annotatePipeline (next_phase:ps) stop
 207           where
 208                 keep_this_output
 209                      | next_phase == stop = Persistent
 210                      | otherwise =
 211                         case next_phase of
 212                              Ln -> Persistent
 213                              Mangle | keep_raw_s -> Persistent
 214                              As     | keep_s     -> Persistent
 215                              HCc    | keep_hc    -> Persistent
 216                              _other              -> Temporary
 217
 218         -- add information about output files to the pipeline
 219         -- the suffix on an output file is determined by the next phase
 220         -- in the pipeline, so we add linking to the end of the pipeline
 221         -- to force the output from the final phase to be a .o file.
 222       stop_phase = case todo of StopBefore phase -> phase
 223                                 DoMkDependHS     -> Ln
 224                                 DoLink           -> Ln
 225       annotated_pipeline = annotatePipeline (pipeline ++ [ Ln ]) stop_phase
 226
 227       phase_ne p (p1,_,_) = (p1 /= p)
 228    ----------- -----  ----   ---   --   --  -  -  -
 229
 230    return $
 231      dropWhile (phase_ne start_phase) .
 232         foldr (\p ps -> if phase_ne stop_phase p then p:ps else [])  []
 233                 $ annotated_pipeline
 234
 235
 236 runPipeline
 237   :: [ (Phase, IntermediateFileType, String) ] -- phases to run
 238   -> String                     -- input file
 239   -> Bool                       -- doing linking afterward?
 240   -> Bool                       -- take into account -o when generating output?
 241   -> IO String                  -- return final filename
 242
 243 runPipeline pipeline input_fn do_linking use_ofile
 244   = pipeLoop pipeline input_fn do_linking use_ofile basename suffix
 245   where (basename, suffix) = splitFilename input_fn
 246
 247 pipeLoop [] input_fn _ _ _ _ = return input_fn
 248 pipeLoop ((phase, keep, o_suffix):phases)
 249         input_fn do_linking use_ofile orig_basename orig_suffix
 250   = do
 251
 252      output_fn <- outputFileName (null phases) keep o_suffix
 253
 254      carry_on <- run_phase phase orig_basename orig_suffix input_fn output_fn
 255         -- sometimes we bail out early, eg. when the compiler's recompilation
 256         -- checker has determined that recompilation isn't necessary.
 257      if not carry_on
 258         then do let (_,keep,final_suffix) = last phases
 259                 ofile <- outputFileName True keep final_suffix
 260                 return ofile
 261         else do -- carry on ...
 262
 263         -- sadly, ghc -E is supposed to write the file to stdout.  We
 264         -- generate <file>.cpp, so we also have to cat the file here.
 265      when (null phases && phase == Cpp) $
 266         run_something "Dump pre-processed file to stdout"
 267                       ("cat " ++ output_fn)
 268
 269      pipeLoop phases output_fn do_linking use_ofile orig_basename orig_suffix
 270
 271   where
 272      outputFileName last_phase keep suffix
 273         = do o_file <- readIORef v_Output_file
 274              if last_phase && not do_linking && use_ofile && isJust o_file
 275                then case o_file of
 276                        Just s  -> return s
 277                        Nothing -> error "outputFileName"
 278                else if keep == Persistent
 279                            then do f <- odir_ify (orig_basename ++ '.':suffix)
 280                                    osuf_ify f
 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_Output_suf
 346    let osuf = case osuf_opt of
 347                         Nothing -> "o"
 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 -> current_dir ++ "/" ++ basename
 414                                         ++ "." ++ hisuf
 415                            Just fn -> fn
 416
 417   -- figure out if the source has changed, for recompilation avoidance.
 418   -- only do this if we're eventually going to generate a .o file.
 419   -- (ToDo: do when generating .hc files too?)
 420   --
 421   -- Setting source_unchanged to True means that M.o seems
 422   -- to be up to date wrt M.hs; so no need to recompile unless imports have
 423   -- changed (which the compiler itself figures out).
 424   -- Setting source_unchanged to False tells the compiler that M.o is out of
 425   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
 426         do_recomp <- readIORef v_Recomp
 427         todo <- readIORef v_GhcMode
 428         o_file <- odir_ify (basename ++ '.':phaseInputExt Ln)
 429         source_unchanged <-
 430           if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
 431              then return False
 432              else do t1 <- getModificationTime (basename ++ '.':suff)
 433                      o_file_exists <- doesFileExist o_file
 434                      if not o_file_exists
 435                         then return False       -- Need to recompile
 436                         else do t2 <- getModificationTime o_file
 437                                 if t2 > t1
 438                                   then return True
 439                                   else return False
 440
 441    -- build a ModuleLocation to pass to hscMain.
 442         let location = ModuleLocation {
 443                           ml_hs_file   = Nothing,
 444                           ml_hspp_file = Just input_fn,
 445                           ml_hi_file   = Just hifile,
 446                           ml_obj_file  = Just o_file
 447                        }
 448
 449   -- get the DynFlags
 450         dyn_flags <- readIORef v_DynFlags
 451
 452   -- run the compiler!
 453         pcs <- initPersistentCompilerState
 454         result <- hscMain dyn_flags{ hscOutName = output_fn }
 455                           source_unchanged
 456                           location
 457                           Nothing        -- no iface
 458                           emptyModuleEnv -- HomeSymbolTable
 459                           emptyModuleEnv -- HomeIfaceTable
 460                           pcs
 461
 462         case result of {
 463
 464             HscFail pcs -> throwDyn (PhaseFailed "hsc" (ExitFailure 1));
 465
 466             HscOK details maybe_iface maybe_stub_h maybe_stub_c
 467                         _maybe_interpreted_code pcs -> do
 468
 469             -- deal with stubs
 470         maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
 471         case maybe_stub_o of
 472                 Nothing -> return ()
 473                 Just stub_o -> add v_Ld_inputs stub_o
 474
 475         let keep_going = case maybe_iface of Just _ -> True; Nothing -> False
 476         return keep_going
 477     }
 478
 479 -----------------------------------------------------------------------------
 480 -- Cc phase
 481
 482 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 483 -- way too many hacks, and I can't say I've ever used it anyway.
 484
 485 run_phase cc_phase _basename _suff input_fn output_fn
 486    | cc_phase == Cc || cc_phase == HCc
 487    = do cc <- readIORef v_Pgm_c
 488         cc_opts <- (getOpts opt_c)
 489         cmdline_include_dirs <- readIORef v_Include_paths
 490
 491         let hcc = cc_phase == HCc
 492
 493                 -- add package include paths even if we're just compiling
 494                 -- .c files; this is the Value Add(TM) that using
 495                 -- ghc instead of gcc gives you :)
 496         pkg_include_dirs <- getPackageIncludePath
 497         let include_paths = map (\p -> "-I"++p) (cmdline_include_dirs
 498                                                         ++ pkg_include_dirs)
 499
 500         c_includes <- getPackageCIncludes
 501         cmdline_includes <- readState cmdline_hc_includes -- -#include options
 502
 503         let cc_injects | hcc = unlines (map mk_include
 504                                         (c_includes ++ reverse cmdline_includes))
 505                        | otherwise = ""
 506             mk_include h_file =
 507                 case h_file of
 508                    '"':_{-"-} -> "#include "++h_file
 509                    '<':_      -> "#include "++h_file
 510                    _          -> "#include \""++h_file++"\""
 511
 512         cc_help <- newTempName "c"
 513         h <- openFile cc_help WriteMode
 514         hPutStr h cc_injects
 515         hPutStrLn h ("#include \"" ++ input_fn ++ "\"\n")
 516         hClose h
 517
 518         ccout <- newTempName "ccout"
 519
 520         mangle <- readIORef v_Do_asm_mangling
 521         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
 522
 523         verb <- is_verbose
 524
 525         o2 <- readIORef v_minus_o2_for_C
 526         let opt_flag | o2        = "-O2"
 527                      | otherwise = "-O"
 528
 529         pkg_extra_cc_opts <- getPackageExtraCcOpts
 530
 531         excessPrecision <- readIORef v_Excess_precision
 532
 533         run_something "C Compiler"
 534          (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
 535                    ++ md_c_flags
 536                    ++ (if cc_phase == HCc && mangle
 537                          then md_regd_c_flags
 538                          else [])
 539                    ++ [ verb, "-S", "-Wimplicit", opt_flag ]
 540                    ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 541                    ++ cc_opts
 542 #ifdef mingw32_TARGET_OS
 543                    ++ [" -mno-cygwin"]
 544 #endif
 545                    ++ (if excessPrecision then [] else [ "-ffloat-store" ])
 546                    ++ include_paths
 547                    ++ pkg_extra_cc_opts
 548 --                 ++ [">", ccout]
 549                    ))
 550         return True
 551
 552         -- ToDo: postprocess the output from gcc
 553
 554 -----------------------------------------------------------------------------
 555 -- Mangle phase
 556
 557 run_phase Mangle _basename _suff input_fn output_fn
 558   = do mangler <- readIORef v_Pgm_m
 559        mangler_opts <- getOpts opt_m
 560        machdep_opts <-
 561          if (prefixMatch "i386" cTARGETPLATFORM)
 562             then do n_regs <- readState stolen_x86_regs
 563                     return [ show n_regs ]
 564             else return []
 565        run_something "Assembly Mangler"
 566         (unwords (mangler :
 567                      mangler_opts
 568                   ++ [ input_fn, output_fn ]
 569                   ++ machdep_opts
 570                 ))
 571        return True
 572
 573 -----------------------------------------------------------------------------
 574 -- Splitting phase
 575
 576 run_phase SplitMangle _basename _suff input_fn _output_fn
 577   = do  splitter <- readIORef v_Pgm_s
 578
 579         -- this is the prefix used for the split .s files
 580         tmp_pfx <- readIORef v_TmpDir
 581         x <- myGetProcessID
 582         let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
 583         writeIORef v_Split_prefix split_s_prefix
 584         addFilesToClean [split_s_prefix ++ "__*"] -- d:-)
 585
 586         -- allocate a tmp file to put the no. of split .s files in (sigh)
 587         n_files <- newTempName "n_files"
 588
 589         run_something "Split Assembly File"
 590          (unwords [ splitter
 591                   , input_fn
 592                   , split_s_prefix
 593                   , n_files ]
 594          )
 595
 596         -- save the number of split files for future references
 597         s <- readFile n_files
 598         let n = read s :: Int
 599         writeIORef v_N_split_files n
 600         return True
 601
 602 -----------------------------------------------------------------------------
 603 -- As phase
 604
 605 run_phase As _basename _suff input_fn output_fn
 606   = do  as <- readIORef v_Pgm_a
 607         as_opts <- getOpts opt_a
 608
 609         cmdline_include_paths <- readIORef v_Include_paths
 610         let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
 611         run_something "Assembler"
 612            (unwords (as : as_opts
 613                        ++ cmdline_include_flags
 614                        ++ [ "-c", input_fn, "-o",  output_fn ]
 615                     ))
 616         return True
 617
 618 run_phase SplitAs basename _suff _input_fn _output_fn
 619   = do  as <- readIORef v_Pgm_a
 620         as_opts <- getOpts opt_a
 621
 622         split_s_prefix <- readIORef v_Split_prefix
 623         n <- readIORef v_N_split_files
 624
 625         odir <- readIORef v_Output_dir
 626         let real_odir = case odir of
 627                                 Nothing -> basename
 628                                 Just d  -> d
 629
 630         let assemble_file n = do
 631                     let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
 632                     let output_o = newdir real_odir
 633                                         (basename ++ "__" ++ show n ++ ".o")
 634                     real_o <- osuf_ify output_o
 635                     run_something "Assembler"
 636                             (unwords (as : as_opts
 637                                       ++ [ "-c", "-o", real_o, input_s ]
 638                             ))
 639
 640         mapM_ assemble_file [1..n]
 641         return True
 642
 643 -----------------------------------------------------------------------------
 644 -- Linking
 645
 646 doLink :: [String] -> IO ()
 647 doLink o_files = do
 648     ln <- readIORef v_Pgm_l
 649     verb <- is_verbose
 650     o_file <- readIORef v_Output_file
 651     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
 652
 653     pkg_lib_paths <- getPackageLibraryPath
 654     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
 655
 656     lib_paths <- readIORef v_Library_paths
 657     let lib_path_opts = map ("-L"++) lib_paths
 658
 659     pkg_libs <- getPackageLibraries
 660     let pkg_lib_opts = map (\lib -> "-l"++lib) pkg_libs
 661
 662     libs <- readIORef v_Cmdline_libraries
 663     let lib_opts = map ("-l"++) (reverse libs)
 664          -- reverse because they're added in reverse order from the cmd line
 665
 666     pkg_extra_ld_opts <- getPackageExtraLdOpts
 667
 668         -- probably _stub.o files
 669     extra_ld_inputs <- readIORef v_Ld_inputs
 670
 671         -- opts from -optl-<blah>
 672     extra_ld_opts <- getStaticOpts v_Opt_l
 673
 674     run_something "Linker"
 675        (unwords
 676          ([ ln, verb, "-o", output_fn ]
 677          ++ o_files
 678          ++ extra_ld_inputs
 679          ++ lib_path_opts
 680          ++ lib_opts
 681          ++ pkg_lib_path_opts
 682          ++ pkg_lib_opts
 683          ++ pkg_extra_ld_opts
 684          ++ extra_ld_opts
 685         )
 686        )
 687
 688 -----------------------------------------------------------------------------
 689 -- Just preprocess a file, put the result in a temp. file (used by the
 690 -- compilation manager during the summary phase).
 691
 692 preprocess :: FilePath -> IO FilePath
 693 preprocess filename =
 694   ASSERT(haskellish_file filename)
 695   do pipeline <- genPipeline (StopBefore Hsc) ("preprocess") filename
 696      runPipeline pipeline filename False{-no linking-} False{-no -o flag-}
 697
 698
 699 -----------------------------------------------------------------------------
 700 -- Compile a single module, under the control of the compilation manager.
 701 --
 702 -- This is the interface between the compilation manager and the
 703 -- compiler proper (hsc), where we deal with tedious details like
 704 -- reading the OPTIONS pragma from the source file, and passing the
 705 -- output of hsc through the C compiler.
 706
 707 -- The driver sits between 'compile' and 'hscMain', translating calls
 708 -- to the former into calls to the latter, and results from the latter
 709 -- into results from the former.  It does things like preprocessing
 710 -- the .hs file if necessary, and compiling up the .stub_c files to
 711 -- generate Linkables.
 712
 713 compile :: ModSummary              -- summary, including source
 714         -> Maybe ModIface          -- old interface, if available
 715         -> HomeSymbolTable         -- for home module ModDetails
 716         -> HomeIfaceTable          -- for home module Ifaces
 717         -> PersistentCompilerState -- persistent compiler state
 718         -> IO CompResult
 719
 720 data CompResult
 721    = CompOK   ModDetails  -- new details (HST additions)
 722               (Maybe (ModIface, Linkable))
 723                        -- summary and code; Nothing => compilation not reqd
 724                        -- (old summary and code are still valid)
 725               PersistentCompilerState   -- updated PCS
 726
 727    | CompErrs PersistentCompilerState   -- updated PCS
 728
 729
 730 compile summary old_iface hst hit pcs = do
 731    verb <- readIORef v_Verbose
 732    when verb (hPutStrLn stderr
 733                  (showSDoc (text "compile: compiling"
 734                             <+> ppr (name_of_summary summary))))
 735
 736    init_dyn_flags <- readIORef v_InitDynFlags
 737    writeIORef v_DynFlags init_dyn_flags
 738
 739    let location = ms_location summary
 740    let input_fn = unJust (ml_hs_file location) "compile:hs"
 741
 742    when verb (hPutStrLn stderr ("compile: input file " ++ input_fn))
 743
 744    opts <- getOptionsFromSource input_fn
 745    processArgs dynamic_flags opts []
 746    dyn_flags <- readIORef v_DynFlags
 747
 748    hsc_lang <- readIORef v_Hsc_Lang
 749    output_fn <- case hsc_lang of
 750                     HscAsm         -> newTempName (phaseInputExt As)
 751                     HscC           -> newTempName (phaseInputExt HCc)
 752                     HscJava        -> newTempName "java" -- ToDo
 753                     HscInterpreted -> return (error "no output file")
 754
 755    -- run the compiler
 756    hsc_result <- hscMain dyn_flags{ hscOutName = output_fn }
 757                          (panic "compile:source_unchanged")
 758                          location old_iface hst hit pcs
 759
 760    case hsc_result of {
 761       HscFail pcs -> return (CompErrs pcs);
 762
 763       HscOK details maybe_iface
 764         maybe_stub_h maybe_stub_c maybe_interpreted_code pcs -> do
 765
 766            -- if no compilation happened, bail out early
 767            case maybe_iface of {
 768                 Nothing -> return (CompOK details Nothing pcs);
 769                 Just iface -> do
 770
 771            let (basename, _) = splitFilename input_fn
 772            maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
 773            let stub_unlinked = case maybe_stub_o of
 774                                   Nothing -> []
 775                                   Just stub_o -> [ DotO stub_o ]
 776
 777            hs_unlinked <-
 778              case hsc_lang of
 779
 780                 -- in interpreted mode, just return the compiled code
 781                 -- as our "unlinked" object.
 782                 HscInterpreted ->
 783                     case maybe_interpreted_code of
 784                         Just (code,itbl_env) -> return [Trees code itbl_env]
 785                         Nothing -> panic "compile: no interpreted code"
 786
 787                 -- we're in batch mode: finish the compilation pipeline.
 788                 _other -> do pipe <- genPipeline (StopBefore Ln) "" output_fn
 789                              o_file <- runPipeline pipe output_fn False False
 790                              return [ DotO o_file ]
 791
 792            let linkable = LM (moduleName (ms_mod summary))
 793                                 (hs_unlinked ++ stub_unlinked)
 794
 795            return (CompOK details (Just (iface, linkable)) pcs)
 796           }
 797    }
 798
 799 -----------------------------------------------------------------------------
 800 -- stub .h and .c files (for foreign export support)
 801
 802 dealWithStubs basename maybe_stub_h maybe_stub_c
 803
 804  = do   let stub_h = basename ++ "_stub.h"
 805         let stub_c = basename ++ "_stub.c"
 806
 807   -- copy the .stub_h file into the current dir if necessary
 808         case maybe_stub_h of
 809            Nothing -> return ()
 810            Just tmp_stub_h -> do
 811                 run_something "Copy stub .h file"
 812                                 ("cp " ++ tmp_stub_h ++ ' ':stub_h)
 813
 814                         -- #include <..._stub.h> in .hc file
 815                 addCmdlineHCInclude tmp_stub_h  -- hack
 816
 817   -- copy the .stub_c file into the current dir, and compile it, if necessary
 818         case maybe_stub_c of
 819            Nothing -> return Nothing
 820            Just tmp_stub_c -> do  -- copy the _stub.c file into the current dir
 821                 run_something "Copy stub .c file"
 822                     (unwords [
 823                         "rm -f", stub_c, "&&",
 824                         "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
 825                         "cat", tmp_stub_c, ">> ", stub_c
 826                         ])
 827
 828                         -- compile the _stub.c file w/ gcc
 829                 pipeline <- genPipeline (StopBefore Ln) "" stub_c
 830                 stub_o <- runPipeline pipeline stub_c False{-no linking-}
 831                                 False{-no -o option-}
 832
 833                 return (Just stub_o)