ghc/compiler/main/DriverPipeline.hs

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