ghc/compiler/main/DriverPipeline.hs

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