ghc/compiler/main/DriverPipeline.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverPipeline.hs,v 1.50 2001/02/05 17:52:49 rrt 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             (md_c_flags, _) <- machdepCCOpts
 339
 340             runSomething "C pre-processor"
 341                 (unwords
 342                    (["echo '{-# LINE 1 \"" ++ input_fn ++ "\" #-}'", ">", output_fn, "&&",
 343                      cpp, verb]
 344                     ++ include_paths
 345                     ++ hs_src_cpp_opts
 346                     ++ hscpp_opts
 347                     ++ md_c_flags
 348                     ++ [ "-x", "c", input_fn, ">>", output_fn ]
 349                    ))
 350           else do
 351             runSomething "Ineffective C pre-processor"
 352                    ("echo '{-# LINE 1 \""  ++ input_fn ++ "\" #-}' > "
 353                     ++ output_fn ++ " && cat " ++ input_fn
 354                     ++ " >> " ++ output_fn)
 355        return True
 356
 357 -----------------------------------------------------------------------------
 358 -- MkDependHS phase
 359
 360 run_phase MkDependHS basename suff input_fn _output_fn = do
 361    src <- readFile input_fn
 362    let (import_sources, import_normals, module_name) = getImports src
 363
 364    deps_sources <- mapM (findDependency True basename)  import_sources
 365    deps_normals <- mapM (findDependency False basename) import_normals
 366    let deps = deps_sources ++ deps_normals
 367
 368    osuf_opt <- readIORef v_Object_suf
 369    let osuf = case osuf_opt of
 370                         Nothing -> phaseInputExt Ln
 371                         Just s  -> s
 372
 373    extra_suffixes <- readIORef v_Dep_suffixes
 374    let suffixes = osuf : map (++ ('_':osuf)) extra_suffixes
 375        ofiles = map (\suf -> basename ++ '.':suf) suffixes
 376
 377    objs <- mapM odir_ify ofiles
 378
 379    hdl <- readIORef v_Dep_tmp_hdl
 380
 381         -- std dependency of the object(s) on the source file
 382    hPutStrLn hdl (unwords objs ++ " : " ++ basename ++ '.':suff)
 383
 384    let genDep (dep, False {- not an hi file -}) =
 385           hPutStrLn hdl (unwords objs ++ " : " ++ dep)
 386        genDep (dep, True  {- is an hi file -}) = do
 387           hisuf <- readIORef v_Hi_suf
 388           let dep_base = remove_suffix '.' dep
 389               deps = (dep_base ++ hisuf)
 390                      : map (\suf -> dep_base ++ suf ++ '_':hisuf) extra_suffixes
 391                   -- length objs should be == length deps
 392           sequence_ (zipWith (\o d -> hPutStrLn hdl (o ++ " : " ++ d)) objs deps)
 393
 394    mapM genDep [ d | Just d <- deps ]
 395
 396    return True
 397
 398 -- add the lines to dep_makefile:
 399            -- always:
 400                    -- this.o : this.hs
 401
 402            -- if the dependency is on something other than a .hi file:
 403                    -- this.o this.p_o ... : dep
 404            -- otherwise
 405                    -- if the import is {-# SOURCE #-}
 406                            -- this.o this.p_o ... : dep.hi-boot[-$vers]
 407
 408                    -- else
 409                            -- this.o ...   : dep.hi
 410                            -- this.p_o ... : dep.p_hi
 411                            -- ...
 412
 413            -- (where .o is $osuf, and the other suffixes come from
 414            -- the cmdline -s options).
 415
 416 -----------------------------------------------------------------------------
 417 -- Hsc phase
 418
 419 -- Compilation of a single module, in "legacy" mode (_not_ under
 420 -- the direction of the compilation manager).
 421 run_phase Hsc basename suff input_fn output_fn
 422   = do
 423
 424   -- we add the current directory (i.e. the directory in which
 425   -- the .hs files resides) to the import path, since this is
 426   -- what gcc does, and it's probably what you want.
 427         let current_dir = getdir basename
 428
 429         paths <- readIORef v_Include_paths
 430         writeIORef v_Include_paths (current_dir : paths)
 431
 432   -- figure out where to put the .hi file
 433         ohi    <- readIORef v_Output_hi
 434         hisuf  <- readIORef v_Hi_suf
 435         let hifile = case ohi of
 436                            Nothing -> basename ++ '.':hisuf
 437                            Just fn -> fn
 438
 439   -- figure out if the source has changed, for recompilation avoidance.
 440   -- only do this if we're eventually going to generate a .o file.
 441   -- (ToDo: do when generating .hc files too?)
 442   --
 443   -- Setting source_unchanged to True means that M.o seems
 444   -- to be up to date wrt M.hs; so no need to recompile unless imports have
 445   -- changed (which the compiler itself figures out).
 446   -- Setting source_unchanged to False tells the compiler that M.o is out of
 447   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
 448         do_recomp <- readIORef v_Recomp
 449         todo <- readIORef v_GhcMode
 450         o_file' <- odir_ify (basename ++ '.':phaseInputExt Ln)
 451         o_file <- osuf_ify o_file'
 452         source_unchanged <-
 453           if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
 454              then return False
 455              else do t1 <- getModificationTime (basename ++ '.':suff)
 456                      o_file_exists <- doesFileExist o_file
 457                      if not o_file_exists
 458                         then return False       -- Need to recompile
 459                         else do t2 <- getModificationTime o_file
 460                                 if t2 > t1
 461                                   then return True
 462                                   else return False
 463
 464    -- build a ModuleLocation to pass to hscMain.
 465         let location = ModuleLocation {
 466                           ml_hs_file   = Nothing,
 467                           ml_hspp_file = Just input_fn,
 468                           ml_hi_file   = Just hifile,
 469                           ml_obj_file  = Just o_file
 470                        }
 471
 472   -- get the DynFlags
 473         dyn_flags <- readIORef v_DynFlags
 474
 475   -- run the compiler!
 476         pcs <- initPersistentCompilerState
 477         result <- hscMain OneShot
 478                           dyn_flags{ hscOutName = output_fn }
 479                           source_unchanged
 480                           location
 481                           Nothing        -- no iface
 482                           emptyModuleEnv -- HomeSymbolTable
 483                           emptyModuleEnv -- HomeIfaceTable
 484                           pcs
 485
 486         case result of {
 487
 488             HscFail pcs -> throwDyn (PhaseFailed "hsc" (ExitFailure 1));
 489
 490             HscNoRecomp pcs details iface ->
 491                 do {
 492                   runSomething "Touching object file" ("touch " ++ o_file);
 493                   return False;
 494                 };
 495
 496             HscRecomp pcs details iface maybe_stub_h maybe_stub_c
 497                       _maybe_interpreted_code -> do
 498
 499             -- deal with stubs
 500         maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
 501         case maybe_stub_o of
 502                 Nothing -> return ()
 503                 Just stub_o -> add v_Ld_inputs stub_o
 504
 505         return True
 506     }
 507
 508 -----------------------------------------------------------------------------
 509 -- Cc phase
 510
 511 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 512 -- way too many hacks, and I can't say I've ever used it anyway.
 513
 514 run_phase cc_phase _basename _suff input_fn output_fn
 515    | cc_phase == Cc || cc_phase == HCc
 516    = do cc <- readIORef v_Pgm_c
 517         cc_opts <- (getOpts opt_c)
 518         cmdline_include_dirs <- readIORef v_Include_paths
 519
 520         let hcc = cc_phase == HCc
 521
 522                 -- add package include paths even if we're just compiling
 523                 -- .c files; this is the Value Add(TM) that using
 524                 -- ghc instead of gcc gives you :)
 525         pkg_include_dirs <- getPackageIncludePath
 526         let include_paths = map (\p -> "-I"++p) (cmdline_include_dirs
 527                                                         ++ pkg_include_dirs)
 528
 529         c_includes <- getPackageCIncludes
 530         cmdline_includes <- dynFlag cmdlineHcIncludes -- -#include options
 531
 532         let cc_injects | hcc = unlines (map mk_include
 533                                         (c_includes ++ reverse cmdline_includes))
 534                        | otherwise = ""
 535             mk_include h_file =
 536                 case h_file of
 537                    '"':_{-"-} -> "#include "++h_file
 538                    '<':_      -> "#include "++h_file
 539                    _          -> "#include \""++h_file++"\""
 540
 541         cc_help <- newTempName "c"
 542         h <- openFile cc_help WriteMode
 543         hPutStr h cc_injects
 544         hPutStrLn h ("#include \"" ++ input_fn ++ "\"\n")
 545         hClose h
 546
 547         ccout <- newTempName "ccout"
 548
 549         mangle <- readIORef v_Do_asm_mangling
 550         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
 551
 552         verb <- getVerbFlag
 553
 554         o2 <- readIORef v_minus_o2_for_C
 555         let opt_flag | o2        = "-O2"
 556                      | otherwise = "-O"
 557
 558         pkg_extra_cc_opts <- getPackageExtraCcOpts
 559
 560         split_objs <- readIORef v_Split_object_files
 561         let split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
 562                       | otherwise         = [ ]
 563
 564         excessPrecision <- readIORef v_Excess_precision
 565
 566         runSomething "C Compiler"
 567          (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
 568                    ++ md_c_flags
 569                    ++ (if cc_phase == HCc && mangle
 570                          then md_regd_c_flags
 571                          else [])
 572                    ++ [ verb, "-S", "-Wimplicit", opt_flag ]
 573                    ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 574                    ++ cc_opts
 575                    ++ split_opt
 576                    ++ (if excessPrecision then [] else [ "-ffloat-store" ])
 577                    ++ include_paths
 578                    ++ pkg_extra_cc_opts
 579 --                 ++ [">", ccout]
 580                    ))
 581         return True
 582
 583         -- ToDo: postprocess the output from gcc
 584
 585 -----------------------------------------------------------------------------
 586 -- Mangle phase
 587
 588 run_phase Mangle _basename _suff input_fn output_fn
 589   = do mangler <- readIORef v_Pgm_m
 590        mangler_opts <- getOpts opt_m
 591        machdep_opts <-
 592          if (prefixMatch "i386" cTARGETPLATFORM)
 593             then do n_regs <- dynFlag stolen_x86_regs
 594                     return [ show n_regs ]
 595             else return []
 596        runSomething "Assembly Mangler"
 597         (unwords (mangler :
 598                      mangler_opts
 599                   ++ [ input_fn, output_fn ]
 600                   ++ machdep_opts
 601                 ))
 602        return True
 603
 604 -----------------------------------------------------------------------------
 605 -- Splitting phase
 606
 607 run_phase SplitMangle _basename _suff input_fn _output_fn
 608   = do  splitter <- readIORef v_Pgm_s
 609
 610         -- this is the prefix used for the split .s files
 611         tmp_pfx <- readIORef v_TmpDir
 612         x <- myGetProcessID
 613         let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
 614         writeIORef v_Split_prefix split_s_prefix
 615         addFilesToClean [split_s_prefix ++ "__*"] -- d:-)
 616
 617         -- allocate a tmp file to put the no. of split .s files in (sigh)
 618         n_files <- newTempName "n_files"
 619
 620         runSomething "Split Assembly File"
 621          (unwords [ splitter
 622                   , input_fn
 623                   , split_s_prefix
 624                   , n_files ]
 625          )
 626
 627         -- save the number of split files for future references
 628         s <- readFile n_files
 629         let n = read s :: Int
 630         writeIORef v_N_split_files n
 631         return True
 632
 633 -----------------------------------------------------------------------------
 634 -- As phase
 635
 636 run_phase As _basename _suff input_fn output_fn
 637   = do  as <- readIORef v_Pgm_a
 638         as_opts <- getOpts opt_a
 639
 640         cmdline_include_paths <- readIORef v_Include_paths
 641         let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
 642         runSomething "Assembler"
 643            (unwords (as : as_opts
 644                        ++ cmdline_include_flags
 645                        ++ [ "-c", input_fn, "-o",  output_fn ]
 646                     ))
 647         return True
 648
 649 run_phase SplitAs basename _suff _input_fn _output_fn
 650   = do  as <- readIORef v_Pgm_a
 651         as_opts <- getOpts opt_a
 652
 653         split_s_prefix <- readIORef v_Split_prefix
 654         n <- readIORef v_N_split_files
 655
 656         odir <- readIORef v_Output_dir
 657         let real_odir = case odir of
 658                                 Nothing -> basename
 659                                 Just d  -> d
 660
 661         let assemble_file n = do
 662                     let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
 663                     let output_o = newdir real_odir
 664                                         (basename ++ "__" ++ show n ++ ".o")
 665                     real_o <- osuf_ify output_o
 666                     runSomething "Assembler"
 667                             (unwords (as : as_opts
 668                                       ++ [ "-c", "-o", real_o, input_s ]
 669                             ))
 670
 671         mapM_ assemble_file [1..n]
 672         return True
 673
 674 -----------------------------------------------------------------------------
 675 -- Linking
 676
 677 doLink :: [String] -> IO ()
 678 doLink o_files = do
 679     ln <- readIORef v_Pgm_l
 680     verb <- getVerbFlag
 681     static <- readIORef v_Static
 682     let imp = if static then "" else "_imp"
 683     no_hs_main <- readIORef v_NoHsMain
 684
 685     o_file <- readIORef v_Output_file
 686     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
 687
 688     pkg_lib_paths <- getPackageLibraryPath
 689     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
 690
 691     lib_paths <- readIORef v_Library_paths
 692     let lib_path_opts = map ("-L"++) lib_paths
 693
 694     pkg_libs <- getPackageLibraries
 695     let pkg_lib_opts = map (\lib -> "-l" ++ lib ++ imp) pkg_libs
 696
 697     libs <- readIORef v_Cmdline_libraries
 698     let lib_opts = map ("-l"++) (reverse libs)
 699          -- reverse because they're added in reverse order from the cmd line
 700
 701     pkg_extra_ld_opts <- getPackageExtraLdOpts
 702
 703         -- probably _stub.o files
 704     extra_ld_inputs <- readIORef v_Ld_inputs
 705
 706         -- opts from -optl-<blah>
 707     extra_ld_opts <- getStaticOpts v_Opt_l
 708
 709     rts_pkg <- getPackageDetails ["rts"]
 710     std_pkg <- getPackageDetails ["std"]
 711 #ifdef mingw32_TARGET_OS
 712     let extra_os = if static || no_hs_main
 713                    then []
 714                    else [ head (library_dirs (head rts_pkg)) ++ "/Main.dll_o",
 715                           head (library_dirs (head std_pkg)) ++ "/PrelMain.dll_o" ]
 716 #endif
 717     (md_c_flags, _) <- machdepCCOpts
 718     runSomething "Linker"
 719        (unwords
 720          ([ ln, verb, "-o", output_fn ]
 721          ++ md_c_flags
 722          ++ o_files
 723 #ifdef mingw32_TARGET_OS
 724          ++ extra_os
 725 #endif
 726          ++ extra_ld_inputs
 727          ++ lib_path_opts
 728          ++ lib_opts
 729          ++ pkg_lib_path_opts
 730          ++ pkg_lib_opts
 731          ++ pkg_extra_ld_opts
 732          ++ extra_ld_opts
 733 #ifdef mingw32_TARGET_OS
 734          ++ if static then [ "-u _PrelMain_mainIO_closure" , "-u ___init_PrelMain"] else []
 735 #else
 736          ++ [ "-u PrelMain_mainIO_closure" , "-u __init_PrelMain"]
 737 #endif
 738         )
 739        )
 740
 741 -----------------------------------------------------------------------------
 742 -- Making a DLL
 743
 744 -- only for Win32, but bits that are #ifdefed in doLn are still #ifdefed here
 745 -- in a vain attempt to aid future portability
 746 doMkDLL :: [String] -> IO ()
 747 doMkDLL o_files = do
 748     ln <- readIORef v_Pgm_dll
 749     verb <- getVerbFlag
 750     static <- readIORef v_Static
 751     let imp = if static then "" else "_imp"
 752     no_hs_main <- readIORef v_NoHsMain
 753
 754     o_file <- readIORef v_Output_file
 755     let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
 756
 757     pkg_lib_paths <- getPackageLibraryPath
 758     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
 759
 760     lib_paths <- readIORef v_Library_paths
 761     let lib_path_opts = map ("-L"++) lib_paths
 762
 763     pkg_libs <- getPackageLibraries
 764     let pkg_lib_opts = map (\lib -> "-l" ++ lib ++ imp) pkg_libs
 765
 766     libs <- readIORef v_Cmdline_libraries
 767     let lib_opts = map ("-l"++) (reverse libs)
 768          -- reverse because they're added in reverse order from the cmd line
 769
 770     pkg_extra_ld_opts <- getPackageExtraLdOpts
 771
 772         -- probably _stub.o files
 773     extra_ld_inputs <- readIORef v_Ld_inputs
 774
 775         -- opts from -optdll-<blah>
 776     extra_ld_opts <- getStaticOpts v_Opt_dll
 777
 778     rts_pkg <- getPackageDetails ["rts"]
 779     std_pkg <- getPackageDetails ["std"]
 780 #ifdef mingw32_TARGET_OS
 781     let extra_os = if static || no_hs_main
 782                    then []
 783                    else [ head (library_dirs (head rts_pkg)) ++ "/Main.dll_o",
 784                           head (library_dirs (head std_pkg)) ++ "/PrelMain.dll_o" ]
 785 #endif
 786     (md_c_flags, _) <- machdepCCOpts
 787     runSomething "DLL creator"
 788        (unwords
 789          ([ ln, verb, "-o", output_fn ]
 790          ++ md_c_flags
 791          ++ o_files
 792 #ifdef mingw32_TARGET_OS
 793          ++ extra_os
 794          ++ [ "--target=i386-mingw32" ]
 795 #endif
 796          ++ extra_ld_inputs
 797          ++ lib_path_opts
 798          ++ lib_opts
 799          ++ pkg_lib_path_opts
 800          ++ pkg_lib_opts
 801          ++ pkg_extra_ld_opts
 802          ++ (case findPS (packString (concat extra_ld_opts)) (packString "--def") of
 803                Nothing -> [ "--export-all" ]
 804                Just _  -> [ "" ])
 805          ++ extra_ld_opts
 806         )
 807        )
 808
 809 -----------------------------------------------------------------------------
 810 -- Just preprocess a file, put the result in a temp. file (used by the
 811 -- compilation manager during the summary phase).
 812
 813 preprocess :: FilePath -> IO FilePath
 814 preprocess filename =
 815   ASSERT(haskellish_file filename)
 816   do init_dyn_flags <- readIORef v_InitDynFlags
 817      writeIORef v_DynFlags init_dyn_flags
 818      pipeline <- genPipeline (StopBefore Hsc) ("preprocess") False
 819                         defaultHscLang filename
 820      runPipeline pipeline filename False{-no linking-} False{-no -o flag-}
 821
 822 -----------------------------------------------------------------------------
 823 -- Compile a single module, under the control of the compilation manager.
 824 --
 825 -- This is the interface between the compilation manager and the
 826 -- compiler proper (hsc), where we deal with tedious details like
 827 -- reading the OPTIONS pragma from the source file, and passing the
 828 -- output of hsc through the C compiler.
 829
 830 -- The driver sits between 'compile' and 'hscMain', translating calls
 831 -- to the former into calls to the latter, and results from the latter
 832 -- into results from the former.  It does things like preprocessing
 833 -- the .hs file if necessary, and compiling up the .stub_c files to
 834 -- generate Linkables.
 835
 836 -- NB.  No old interface can also mean that the source has changed.
 837
 838 compile :: GhciMode                -- distinguish batch from interactive
 839         -> ModSummary              -- summary, including source
 840         -> Bool                    -- source unchanged?
 841         -> Maybe ModIface          -- old interface, if available
 842         -> HomeSymbolTable         -- for home module ModDetails
 843         -> HomeIfaceTable          -- for home module Ifaces
 844         -> PersistentCompilerState -- persistent compiler state
 845         -> IO CompResult
 846
 847 data CompResult
 848    = CompOK   PersistentCompilerState   -- updated PCS
 849               ModDetails  -- new details (HST additions)
 850               ModIface    -- new iface   (HIT additions)
 851               (Maybe Linkable)
 852                        -- new code; Nothing => compilation was not reqd
 853                        -- (old code is still valid)
 854
 855    | CompErrs PersistentCompilerState   -- updated PCS
 856
 857
 858 compile ghci_mode summary source_unchanged old_iface hst hit pcs = do
 859    init_dyn_flags <- readIORef v_InitDynFlags
 860    writeIORef v_DynFlags init_dyn_flags
 861
 862    showPass init_dyn_flags
 863         (showSDoc (text "Compiling" <+> ppr (name_of_summary summary)))
 864
 865    let verb = verbosity init_dyn_flags
 866    let location   = ms_location summary
 867    let input_fn   = unJust "compile:hs" (ml_hs_file location)
 868    let input_fnpp = unJust "compile:hspp" (ml_hspp_file location)
 869
 870    when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp))
 871
 872    opts <- getOptionsFromSource input_fnpp
 873    processArgs dynamic_flags opts []
 874    dyn_flags <- readIORef v_DynFlags
 875
 876    let hsc_lang = hscLang dyn_flags
 877    output_fn <- case hsc_lang of
 878                     HscAsm         -> newTempName (phaseInputExt As)
 879                     HscC           -> newTempName (phaseInputExt HCc)
 880                     HscJava        -> newTempName "java" -- ToDo
 881                     HscInterpreted -> return (error "no output file")
 882
 883    -- run the compiler
 884    hsc_result <- hscMain ghci_mode dyn_flags{ hscOutName = output_fn }
 885                          source_unchanged
 886                          location old_iface hst hit pcs
 887
 888    case hsc_result of
 889       HscFail pcs -> return (CompErrs pcs)
 890
 891       HscNoRecomp pcs details iface -> return (CompOK pcs details iface Nothing)
 892
 893       HscRecomp pcs details iface
 894         maybe_stub_h maybe_stub_c maybe_interpreted_code -> do
 895
 896            let (basename, _) = splitFilename input_fn
 897            maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
 898            let stub_unlinked = case maybe_stub_o of
 899                                   Nothing -> []
 900                                   Just stub_o -> [ DotO stub_o ]
 901
 902            (hs_unlinked, unlinked_time) <-
 903              case hsc_lang of
 904
 905                 -- in interpreted mode, just return the compiled code
 906                 -- as our "unlinked" object.
 907                 HscInterpreted ->
 908                     case maybe_interpreted_code of
 909                        Just (bcos,itbl_env) -> do tm <- getClockTime
 910                                                   return ([BCOs bcos itbl_env], tm)
 911                        Nothing -> panic "compile: no interpreted code"
 912
 913                 -- we're in batch mode: finish the compilation pipeline.
 914                 _other -> do pipe <- genPipeline (StopBefore Ln) "" True
 915                                         hsc_lang output_fn
 916                              -- runPipeline takes input_fn so it can split off
 917                              -- the base name and use it as the base of
 918                              -- the output object file.
 919                              let (basename, suffix) = splitFilename input_fn
 920                              o_file <- pipeLoop pipe output_fn False False
 921                                                 basename suffix
 922                              o_time <- getModificationTime o_file
 923                              return ([DotO o_file], o_time)
 924
 925            let linkable = LM unlinked_time (moduleName (ms_mod summary))
 926                              (hs_unlinked ++ stub_unlinked)
 927
 928            return (CompOK pcs details iface (Just linkable))
 929
 930
 931 -----------------------------------------------------------------------------
 932 -- stub .h and .c files (for foreign export support)
 933
 934 dealWithStubs basename maybe_stub_h maybe_stub_c
 935
 936  = do   let stub_h = basename ++ "_stub.h"
 937         let stub_c = basename ++ "_stub.c"
 938
 939   -- copy the .stub_h file into the current dir if necessary
 940         case maybe_stub_h of
 941            Nothing -> return ()
 942            Just tmp_stub_h -> do
 943                 runSomething "Copy stub .h file"
 944                                 ("cp " ++ tmp_stub_h ++ ' ':stub_h)
 945
 946                         -- #include <..._stub.h> in .hc file
 947                 addCmdlineHCInclude tmp_stub_h  -- hack
 948
 949   -- copy the .stub_c file into the current dir, and compile it, if necessary
 950         case maybe_stub_c of
 951            Nothing -> return Nothing
 952            Just tmp_stub_c -> do  -- copy the _stub.c file into the current dir
 953                 runSomething "Copy stub .c file"
 954                     (unwords [
 955                         "rm -f", stub_c, "&&",
 956                         "echo \'#include \"Stg.h\"\n#include \""++stub_h++"\"\' >"++stub_c, " &&",
 957                         "cat", tmp_stub_c, ">> ", stub_c
 958                         ])
 959
 960                         -- compile the _stub.c file w/ gcc
 961                 pipeline <- genPipeline (StopBefore Ln) "" True
 962                                 defaultHscLang stub_c
 963                 stub_o <- runPipeline pipeline stub_c False{-no linking-}
 964                                 False{-no -o option-}
 965
 966                 return (Just stub_o)