ghc/compiler/main/DriverPipeline.hs

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