ghc/compiler/main/DriverPipeline.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverPipeline.hs,v 1.87 2001/07/11 01:27:04 sof 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 Packages
  30 import CmTypes
  31 import GetImports
  32 import DriverState
  33 import DriverUtil
  34 import DriverMkDepend
  35 import DriverPhases
  36 import DriverFlags
  37 import SysTools         ( newTempName, addFilesToClean, getSysMan )
  38 import qualified SysTools
  39 import HscMain
  40 import Finder
  41 import HscTypes
  42 import Outputable
  43 import Module
  44 import ErrUtils
  45 import CmdLineOpts
  46 import Config
  47 import Panic
  48 import Util
  49
  50 import Time             ( getClockTime )
  51 import Directory
  52 import System
  53 import IOExts
  54 import Exception
  55
  56 import IO
  57 import Monad
  58 import Maybe
  59
  60 import PackedString
  61 import MatchPS
  62
  63 -----------------------------------------------------------------------------
  64 -- GHC modes of operation
  65
  66 modeFlag :: String -> Maybe GhcMode
  67 modeFlag "-M"            = Just $ DoMkDependHS
  68 modeFlag "--mk-dll"      = Just $ DoMkDLL
  69 modeFlag "-E"            = Just $ StopBefore Hsc
  70 modeFlag "-C"            = Just $ StopBefore HCc
  71 modeFlag "-S"            = Just $ StopBefore As
  72 modeFlag "-c"            = Just $ StopBefore Ln
  73 modeFlag "--make"        = Just $ DoMake
  74 modeFlag "--interactive" = Just $ DoInteractive
  75 modeFlag _               = Nothing
  76
  77 getGhcMode :: [String]
  78          -> IO ( [String]   -- rest of command line
  79                , GhcMode
  80                , String     -- "GhcMode" flag
  81                )
  82 getGhcMode flags
  83   = case my_partition modeFlag flags of
  84         ([]   , rest) -> return (rest, DoLink,  "") -- default is to do linking
  85         ([(flag,one)], rest) -> return (rest, one, flag)
  86         (_    , _   ) ->
  87           throwDyn (UsageError
  88                 "only one of the flags -M, -E, -C, -S, -c, --make, --interactive, -mk-dll is allowed")
  89
  90 -----------------------------------------------------------------------------
  91 -- genPipeline
  92 --
  93 -- Herein is all the magic about which phases to run in which order, whether
  94 -- the intermediate files should be in TMPDIR or in the current directory,
  95 -- what the suffix of the intermediate files should be, etc.
  96
  97 -- The following compilation pipeline algorithm is fairly hacky.  A
  98 -- better way to do this would be to express the whole compilation as a
  99 -- data flow DAG, where the nodes are the intermediate files and the
 100 -- edges are the compilation phases.  This framework would also work
 101 -- nicely if a haskell dependency generator was included in the
 102 -- driver.
 103
 104 -- It would also deal much more cleanly with compilation phases that
 105 -- generate multiple intermediates, (eg. hsc generates .hc, .hi, and
 106 -- possibly stub files), where some of the output files need to be
 107 -- processed further (eg. the stub files need to be compiled by the C
 108 -- compiler).
 109
 110 -- A cool thing to do would then be to execute the data flow graph
 111 -- concurrently, automatically taking advantage of extra processors on
 112 -- the host machine.  For example, when compiling two Haskell files
 113 -- where one depends on the other, the data flow graph would determine
 114 -- that the C compiler from the first compilation can be overlapped
 115 -- with the hsc compilation for the second file.
 116
 117 data IntermediateFileType
 118   = Temporary
 119   | Persistent
 120   deriving (Eq, Show)
 121
 122 genPipeline
 123    :: GhcMode           -- when to stop
 124    -> String            -- "stop after" flag (for error messages)
 125    -> Bool              -- True => output is persistent
 126    -> HscLang           -- preferred output language for hsc
 127    -> String            -- original filename
 128    -> IO [              -- list of phases to run for this file
 129              (Phase,
 130               IntermediateFileType,  -- keep the output from this phase?
 131               String)                -- output file suffix
 132          ]
 133
 134 genPipeline todo stop_flag persistent_output lang filename
 135  = do
 136    split      <- readIORef v_Split_object_files
 137    mangle     <- readIORef v_Do_asm_mangling
 138    keep_hc    <- readIORef v_Keep_hc_files
 139    keep_raw_s <- readIORef v_Keep_raw_s_files
 140    keep_s     <- readIORef v_Keep_s_files
 141    osuf       <- readIORef v_Object_suf
 142    hcsuf      <- readIORef v_HC_suf
 143
 144    let
 145    ----------- -----  ----   ---   --   --  -  -  -
 146     (_basename, suffix) = splitFilename filename
 147
 148     start = startPhase suffix
 149
 150       -- special case for mkdependHS: .hspp files go through MkDependHS
 151     start_phase | todo == DoMkDependHS && start == Hsc  = MkDependHS
 152                 | otherwise = start
 153
 154     haskellish = haskellish_suffix suffix
 155     cish = cish_suffix suffix
 156
 157        -- for a .hc file we need to force lang to HscC
 158     real_lang | start_phase == HCc || start_phase == Mangle = HscC
 159               | otherwise                                   = lang
 160
 161    let
 162    ----------- -----  ----   ---   --   --  -  -  -
 163     pipeline
 164       | todo == DoMkDependHS = [ Unlit, Cpp, MkDependHS ]
 165
 166       | haskellish =
 167        case real_lang of
 168         HscC    | split && mangle -> [ Unlit, Cpp, Hsc, HCc, Mangle,
 169                                         SplitMangle, SplitAs ]
 170                 | mangle          -> [ Unlit, Cpp, Hsc, HCc, Mangle, As ]
 171                 | split           -> not_valid
 172                 | otherwise       -> [ Unlit, Cpp, Hsc, HCc, As ]
 173
 174         HscAsm  | split           -> [ Unlit, Cpp, Hsc, SplitMangle, SplitAs ]
 175                 | otherwise       -> [ Unlit, Cpp, Hsc, As ]
 176
 177         HscJava | split           -> not_valid
 178                 | otherwise       -> error "not implemented: compiling via Java"
 179         HscILX  | split           -> not_valid
 180                 | otherwise       -> [ Unlit, Cpp, Hsc ]
 181
 182       | cish      = [ Cc, As ]
 183
 184       | otherwise = [ ]  -- just pass this file through to the linker
 185
 186         -- ToDo: this is somewhat cryptic
 187     not_valid = throwDyn (UsageError ("invalid option combination"))
 188
 189     stop_phase = case todo of
 190                         StopBefore As | split -> SplitAs
 191                         StopBefore phase      -> phase
 192                         DoMkDependHS          -> Ln
 193                         DoLink                -> Ln
 194    ----------- -----  ----   ---   --   --  -  -  -
 195
 196         -- this shouldn't happen.
 197    if start_phase /= Ln && start_phase `notElem` pipeline
 198         then throwDyn (CmdLineError ("can't find starting phase for "
 199                                      ++ filename))
 200         else do
 201
 202         -- if we can't find the phase we're supposed to stop before,
 203         -- something has gone wrong.  This test carefully avoids the
 204         -- case where we aren't supposed to do any compilation, because the file
 205         -- is already in linkable form (for example).
 206    if start_phase `elem` pipeline &&
 207         (stop_phase /= Ln && stop_phase `notElem` pipeline)
 208       then throwDyn (UsageError
 209                 ("flag " ++ stop_flag
 210                  ++ " is incompatible with source file `" ++ filename ++ "'"))
 211       else do
 212
 213    let
 214         -- .o and .hc suffixes can be overriden by command-line options:
 215       myPhaseInputExt Ln  | Just s <- osuf  = s
 216       myPhaseInputExt HCc | Just s <- hcsuf = s
 217       myPhaseInputExt other                 = phaseInputExt other
 218
 219       annotatePipeline
 220          :: [Phase]             -- raw pipeline
 221          -> Phase               -- phase to stop before
 222          -> [(Phase, IntermediateFileType, String{-file extension-})]
 223       annotatePipeline []     _    = []
 224       annotatePipeline (Ln:_) _    = []
 225       annotatePipeline (phase:next_phase:ps) stop =
 226           (phase, keep_this_output, myPhaseInputExt next_phase)
 227              : annotatePipeline (next_phase:ps) stop
 228           where
 229                 keep_this_output
 230                      | next_phase == stop
 231                      = if persistent_output then Persistent else Temporary
 232                      | otherwise
 233                      = case next_phase of
 234                              Ln -> Persistent
 235                              Mangle | keep_raw_s -> Persistent
 236                              As     | keep_s     -> Persistent
 237                              HCc    | keep_hc    -> Persistent
 238                              _other              -> Temporary
 239
 240         -- add information about output files to the pipeline
 241         -- the suffix on an output file is determined by the next phase
 242         -- in the pipeline, so we add linking to the end of the pipeline
 243         -- to force the output from the final phase to be a .o file.
 244
 245       annotated_pipeline = annotatePipeline (pipeline ++ [Ln]) stop_phase
 246
 247       phase_ne p (p1,_,_) = (p1 /= p)
 248    ----------- -----  ----   ---   --   --  -  -  -
 249
 250    return (
 251      takeWhile (phase_ne stop_phase ) $
 252      dropWhile (phase_ne start_phase) $
 253      annotated_pipeline
 254     )
 255
 256
 257 runPipeline
 258   :: [ (Phase, IntermediateFileType, String) ] -- phases to run
 259   -> String                     -- input file
 260   -> Bool                       -- doing linking afterward?
 261   -> Bool                       -- take into account -o when generating output?
 262   -> IO String                  -- return final filename
 263
 264 runPipeline pipeline input_fn do_linking use_ofile
 265   = pipeLoop pipeline input_fn do_linking use_ofile basename suffix
 266   where (basename, suffix) = splitFilename input_fn
 267
 268 pipeLoop [] input_fn _ _ _ _ = return input_fn
 269 pipeLoop ((phase, keep, o_suffix):phases)
 270         input_fn do_linking use_ofile orig_basename orig_suffix
 271   = do
 272
 273      output_fn <- outputFileName (null phases) keep o_suffix
 274
 275      mbCarryOn <- run_phase phase orig_basename orig_suffix input_fn output_fn
 276         -- sometimes we bail out early, eg. when the compiler's recompilation
 277         -- checker has determined that recompilation isn't necessary.
 278      case mbCarryOn of
 279        Nothing -> do
 280               let (_,keep,final_suffix) = last phases
 281               ofile <- outputFileName True keep final_suffix
 282               return ofile
 283           -- carry on ...
 284        Just fn -> pipeLoop phases fn do_linking use_ofile orig_basename orig_suffix
 285   where
 286      outputFileName last_phase keep suffix
 287         = do o_file <- readIORef v_Output_file
 288              if last_phase && not do_linking && use_ofile && isJust o_file
 289                then case o_file of
 290                        Just s  -> return s
 291                        Nothing -> error "outputFileName"
 292                else if keep == Persistent
 293                            then odir_ify (orig_basename ++ '.':suffix)
 294                            else newTempName suffix
 295
 296 -------------------------------------------------------------------------------
 297 -- Unlit phase
 298
 299 run_phase Unlit _basename _suff input_fn output_fn
 300   = do unlit_flags <- getOpts opt_L
 301        SysTools.runUnlit (unlit_flags ++ ["-h", input_fn, input_fn, output_fn])
 302        return (Just output_fn)
 303
 304 -------------------------------------------------------------------------------
 305 -- Cpp phase
 306
 307 run_phase Cpp basename suff input_fn output_fn
 308   = do src_opts <- getOptionsFromSource input_fn
 309        unhandled_flags <- processArgs dynamic_flags src_opts []
 310        checkProcessArgsResult unhandled_flags basename suff
 311
 312        do_cpp <- dynFlag cppFlag
 313        if not do_cpp then
 314            -- no need to preprocess CPP, just pass input file along
 315            -- to the next phase of the pipeline.
 316           return (Just input_fn)
 317         else do
 318             hscpp_opts      <- getOpts opt_P
 319             hs_src_cpp_opts <- readIORef v_Hs_source_cpp_opts
 320
 321             cmdline_include_paths <- readIORef v_Include_paths
 322             pkg_include_dirs <- getPackageIncludePath
 323             let include_paths = map (\p -> "-I"++p) (cmdline_include_paths
 324                                                         ++ pkg_include_dirs)
 325
 326             verb <- getVerbFlag
 327             (md_c_flags, _) <- machdepCCOpts
 328
 329             SysTools.runCpp ([verb]
 330                             ++ include_paths
 331                             ++ hs_src_cpp_opts
 332                             ++ hscpp_opts
 333                             ++ md_c_flags
 334                             ++ [ "-x", "c", input_fn, "-o", output_fn ])
 335             return (Just output_fn)
 336
 337 -----------------------------------------------------------------------------
 338 -- MkDependHS phase
 339
 340 run_phase MkDependHS basename suff input_fn output_fn = do
 341    src <- readFile input_fn
 342    let (import_sources, import_normals, _) = getImports src
 343
 344    let orig_fn = basename ++ '.':suff
 345    deps_sources <- mapM (findDependency True  orig_fn) import_sources
 346    deps_normals <- mapM (findDependency False orig_fn) import_normals
 347    let deps = deps_sources ++ deps_normals
 348
 349    osuf_opt <- readIORef v_Object_suf
 350    let osuf = case osuf_opt of
 351                         Nothing -> phaseInputExt Ln
 352                         Just s  -> s
 353
 354    extra_suffixes <- readIORef v_Dep_suffixes
 355    let suffixes = osuf : map (++ ('_':osuf)) extra_suffixes
 356        ofiles = map (\suf -> basename ++ '.':suf) suffixes
 357
 358    objs <- mapM odir_ify ofiles
 359
 360         -- Handle for file that accumulates dependencies
 361    hdl <- readIORef v_Dep_tmp_hdl
 362
 363         -- std dependency of the object(s) on the source file
 364    hPutStrLn hdl (unwords objs ++ " : " ++ basename ++ '.':suff)
 365
 366    let genDep (dep, False {- not an hi file -}) =
 367           hPutStrLn hdl (unwords objs ++ " : " ++ dep)
 368        genDep (dep, True  {- is an hi file -}) = do
 369           hisuf <- readIORef v_Hi_suf
 370           let dep_base = remove_suffix '.' dep
 371               deps = (dep_base ++ hisuf)
 372                      : map (\suf -> dep_base ++ suf ++ '_':hisuf) extra_suffixes
 373                   -- length objs should be == length deps
 374           sequence_ (zipWith (\o d -> hPutStrLn hdl (o ++ " : " ++ d)) objs deps)
 375
 376    mapM genDep [ d | Just d <- deps ]
 377
 378    return (Just output_fn)
 379
 380 -- add the lines to dep_makefile:
 381            -- always:
 382                    -- this.o : this.hs
 383
 384            -- if the dependency is on something other than a .hi file:
 385                    -- this.o this.p_o ... : dep
 386            -- otherwise
 387                    -- if the import is {-# SOURCE #-}
 388                            -- this.o this.p_o ... : dep.hi-boot[-$vers]
 389
 390                    -- else
 391                            -- this.o ...   : dep.hi
 392                            -- this.p_o ... : dep.p_hi
 393                            -- ...
 394
 395            -- (where .o is $osuf, and the other suffixes come from
 396            -- the cmdline -s options).
 397
 398 -----------------------------------------------------------------------------
 399 -- Hsc phase
 400
 401 -- Compilation of a single module, in "legacy" mode (_not_ under
 402 -- the direction of the compilation manager).
 403 run_phase Hsc basename suff input_fn output_fn
 404   = do
 405
 406   -- we add the current directory (i.e. the directory in which
 407   -- the .hs files resides) to the import path, since this is
 408   -- what gcc does, and it's probably what you want.
 409         let current_dir = getdir basename
 410
 411         paths <- readIORef v_Include_paths
 412         writeIORef v_Include_paths (current_dir : paths)
 413
 414   -- figure out which header files to #include in a generated .hc file
 415         c_includes <- getPackageCIncludes
 416         cmdline_includes <- dynFlag cmdlineHcIncludes -- -#include options
 417
 418         let cc_injects = unlines (map mk_include
 419                                  (c_includes ++ reverse cmdline_includes))
 420             mk_include h_file =
 421                 case h_file of
 422                    '"':_{-"-} -> "#include "++h_file
 423                    '<':_      -> "#include "++h_file
 424                    _          -> "#include \""++h_file++"\""
 425
 426         writeIORef v_HCHeader cc_injects
 427
 428   -- gather the imports and module name
 429         (srcimps,imps,mod_name) <- getImportsFromFile input_fn
 430
 431   -- build a ModuleLocation to pass to hscMain.
 432         Just (mod, location')
 433            <- mkHomeModuleLocn mod_name basename (Just (basename ++ '.':suff))
 434
 435   -- take -ohi into account if present
 436         ohi <- readIORef v_Output_hi
 437         let location | Just fn <- ohi = location'{ ml_hi_file = fn }
 438                      | otherwise      = location'
 439
 440   -- figure out if the source has changed, for recompilation avoidance.
 441   -- only do this if we're eventually going to generate a .o file.
 442   -- (ToDo: do when generating .hc files too?)
 443   --
 444   -- Setting source_unchanged to True means that M.o seems
 445   -- to be up to date wrt M.hs; so no need to recompile unless imports have
 446   -- changed (which the compiler itself figures out).
 447   -- Setting source_unchanged to False tells the compiler that M.o is out of
 448   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
 449         do_recomp   <- readIORef v_Recomp
 450         todo        <- readIORef v_GhcMode
 451         expl_o_file <- readIORef v_Output_file
 452         let o_file =
 453                 case expl_o_file of
 454                   Nothing -> unJust "source_unchanged" (ml_obj_file location)
 455                   Just x  -> x
 456         source_unchanged <-
 457           if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
 458              then return False
 459              else do t1 <- getModificationTime (basename ++ '.':suff)
 460                      o_file_exists <- doesFileExist o_file
 461                      if not o_file_exists
 462                         then return False       -- Need to recompile
 463                         else do t2 <- getModificationTime o_file
 464                                 if t2 > t1
 465                                   then return True
 466                                   else return False
 467
 468   -- get the DynFlags
 469         dyn_flags <- getDynFlags
 470
 471         let dyn_flags' = dyn_flags { hscOutName = output_fn,
 472                                      hscStubCOutName = basename ++ "_stub.c",
 473                                      hscStubHOutName = basename ++ "_stub.h",
 474                                      extCoreName = basename ++ ".core" }
 475
 476   -- run the compiler!
 477         pcs <- initPersistentCompilerState
 478         result <- hscMain OneShot
 479                           dyn_flags' mod
 480                           location{ ml_hspp_file=Just input_fn }
 481                           source_unchanged
 482                           False
 483                           Nothing        -- no iface
 484                           emptyModuleEnv -- HomeSymbolTable
 485                           emptyModuleEnv -- HomeIfaceTable
 486                           pcs
 487
 488         case result of {
 489
 490             HscFail pcs -> throwDyn (PhaseFailed "hsc" (ExitFailure 1));
 491
 492             HscNoRecomp pcs details iface -> do { SysTools.touch "Touching object file" o_file
 493                                                 ; return Nothing } ;
 494
 495             HscRecomp pcs details iface stub_h_exists stub_c_exists
 496                       _maybe_interpreted_code -> do
 497
 498             -- deal with stubs
 499         maybe_stub_o <- compileStub dyn_flags' stub_c_exists
 500         case maybe_stub_o of
 501                 Nothing -> return ()
 502                 Just stub_o -> add v_Ld_inputs stub_o
 503
 504         return (Just output_fn)
 505     }
 506
 507 -----------------------------------------------------------------------------
 508 -- Cc phase
 509
 510 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 511 -- way too many hacks, and I can't say I've ever used it anyway.
 512
 513 run_phase cc_phase basename suff input_fn output_fn
 514    | cc_phase == Cc || cc_phase == HCc
 515    = do 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         mangle <- readIORef v_Do_asm_mangling
 528         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
 529
 530         verb <- getVerbFlag
 531
 532         o2 <- readIORef v_minus_o2_for_C
 533         let opt_flag | o2        = "-O2"
 534                      | otherwise = "-O"
 535
 536         pkg_extra_cc_opts <- getPackageExtraCcOpts
 537
 538         split_objs <- readIORef v_Split_object_files
 539         let split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
 540                       | otherwise         = [ ]
 541
 542         excessPrecision <- readIORef v_Excess_precision
 543         SysTools.runCc ([ "-x", "c", input_fn, "-o", output_fn ]
 544                        ++ md_c_flags
 545                        ++ (if cc_phase == HCc && mangle
 546                              then md_regd_c_flags
 547                              else [])
 548                        ++ [ verb, "-S", "-Wimplicit", opt_flag ]
 549                        ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 550                        ++ cc_opts
 551                        ++ split_opt
 552                        ++ (if excessPrecision then [] else [ "-ffloat-store" ])
 553                        ++ include_paths
 554                        ++ pkg_extra_cc_opts
 555                        )
 556         return (Just output_fn)
 557
 558         -- ToDo: postprocess the output from gcc
 559
 560 -----------------------------------------------------------------------------
 561 -- Mangle phase
 562
 563 run_phase Mangle _basename _suff input_fn output_fn
 564   = do mangler_opts <- getOpts opt_m
 565        machdep_opts <- if (prefixMatch "i386" cTARGETPLATFORM)
 566                        then do n_regs <- dynFlag stolen_x86_regs
 567                                return [ show n_regs ]
 568                        else return []
 569
 570        SysTools.runMangle (mangler_opts
 571                           ++ [ input_fn, output_fn ]
 572                           ++ machdep_opts)
 573        return (Just output_fn)
 574
 575 -----------------------------------------------------------------------------
 576 -- Splitting phase
 577
 578 run_phase SplitMangle _basename _suff input_fn output_fn
 579   = do  -- tmp_pfx is the prefix used for the split .s files
 580         -- We also use it as the file to contain the no. of split .s files (sigh)
 581         split_s_prefix <- SysTools.newTempName "split"
 582         let n_files_fn = split_s_prefix
 583
 584         SysTools.runSplit [input_fn, split_s_prefix, n_files_fn]
 585
 586         -- Save the number of split files for future references
 587         s <- readFile n_files_fn
 588         let n_files = read s :: Int
 589         writeIORef v_Split_info (split_s_prefix, n_files)
 590
 591         -- Remember to delete all these files
 592         addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s"
 593                         | n <- [1..n_files]]
 594
 595         return (Just output_fn)
 596
 597 -----------------------------------------------------------------------------
 598 -- As phase
 599
 600 run_phase As _basename _suff input_fn output_fn
 601   = do  as_opts               <- getOpts opt_a
 602         cmdline_include_paths <- readIORef v_Include_paths
 603
 604         SysTools.runAs (as_opts
 605                        ++ [ "-I" ++ p | p <- cmdline_include_paths ]
 606                        ++ [ "-c", input_fn, "-o",  output_fn ])
 607         return (Just output_fn)
 608
 609 run_phase SplitAs basename _suff _input_fn output_fn
 610   = do  as_opts <- getOpts opt_a
 611
 612         (split_s_prefix, n) <- readIORef v_Split_info
 613
 614         odir <- readIORef v_Output_dir
 615         let real_odir = case odir of
 616                                 Nothing -> basename
 617                                 Just d  -> d
 618
 619         let assemble_file n
 620               = do  let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
 621                     let output_o = newdir real_odir
 622                                         (basename ++ "__" ++ show n ++ ".o")
 623                     real_o <- osuf_ify output_o
 624                     SysTools.runAs (as_opts ++ ["-c", "-o", real_o, input_s])
 625
 626         mapM_ assemble_file [1..n]
 627         return (Just output_fn)
 628
 629 -----------------------------------------------------------------------------
 630 -- MoveBinary sort-of-phase
 631 -- After having produced a binary, move it somewhere else and generate a
 632 -- wrapper script calling the binary. Currently, we need this only in
 633 -- a parallel way (i.e. in GUM), because PVM expects the binary in a
 634 -- central directory.
 635 -- This is called from doLink below, after linking. I haven't made it
 636 -- a separate phase to minimise interfering with other modules, and
 637 -- we don't need the generality of a phase (MoveBinary is always
 638 -- done after linking and makes only sense in a parallel setup)   -- HWL
 639
 640 run_phase_MoveBinary input_fn
 641   = do
 642         sysMan   <- getSysMan
 643         pvm_root <- getEnv "PVM_ROOT"
 644         pvm_arch <- getEnv "PVM_ARCH"
 645         let
 646            pvm_executable_base = "=" ++ input_fn
 647            pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
 648         -- nuke old binary; maybe use configur'ed names for cp and rm?
 649         system ("rm -f " ++ pvm_executable)
 650         -- move the newly created binary into PVM land
 651         system ("cp -p " ++ input_fn ++ " " ++ pvm_executable)
 652         -- generate a wrapper script for running a parallel prg under PVM
 653         writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
 654         return True
 655
 656 -- generates a Perl skript starting a parallel prg under PVM
 657 mk_pvm_wrapper_script :: String -> String -> String -> String
 658 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
 659  [
 660   "eval 'exec perl -S $0 ${1+\"$@\"}'",
 661   "  if $running_under_some_shell;",
 662   "# =!=!=!=!=!=!=!=!=!=!=!",
 663   "# This script is automatically generated: DO NOT EDIT!!!",
 664   "# Generated by Glasgow Haskell Compiler",
 665   "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
 666   "#",
 667   "$pvm_executable      = '" ++ pvm_executable ++ "';",
 668   "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
 669   "$SysMan = '" ++ sysMan ++ "';",
 670   "",
 671   {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
 672   "# first, some magical shortcuts to run "commands" on the binary",
 673   "# (which is hidden)",
 674   "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
 675   "    local($cmd) = $1;",
 676   "    system("$cmd $pvm_executable");",
 677   "    exit(0); # all done",
 678   "}", -}
 679   "",
 680   "# Now, run the real binary; process the args first",
 681   "$ENV{'PE'} = $pvm_executable_base;", --  ++ pvm_executable_base,
 682   "$debug = '';",
 683   "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
 684   "@nonPVM_args = ();",
 685   "$in_RTS_args = 0;",
 686   "",
 687   "args: while ($a = shift(@ARGV)) {",
 688   "    if ( $a eq '+RTS' ) {",
 689   "     $in_RTS_args = 1;",
 690   "    } elsif ( $a eq '-RTS' ) {",
 691   "     $in_RTS_args = 0;",
 692   "    }",
 693   "    if ( $a eq '-d' && $in_RTS_args ) {",
 694   "     $debug = '-';",
 695   "    } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
 696   "     $nprocessors = $1;",
 697   "    } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
 698   "     $nprocessors = $1;",
 699   "    } else {",
 700   "     push(@nonPVM_args, $a);",
 701   "    }",
 702   "}",
 703   "",
 704   "local($return_val) = 0;",
 705   "# Start the parallel execution by calling SysMan",
 706   "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
 707   "$return_val = $?;",
 708   "# ToDo: fix race condition moving files and flushing them!!",
 709   "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
 710   "exit($return_val);"
 711  ]
 712
 713 -----------------------------------------------------------------------------
 714 -- Complain about non-dynamic flags in OPTIONS pragmas
 715
 716 checkProcessArgsResult flags basename suff
 717   = do when (not (null flags)) (throwDyn (ProgramError (
 718            basename ++ "." ++ suff
 719            ++ ": static flags are not allowed in {-# OPTIONS #-} pragmas:\n\t"
 720            ++ unwords flags)) (ExitFailure 1))
 721
 722 -----------------------------------------------------------------------------
 723 -- Linking
 724
 725 doLink :: [String] -> IO ()
 726 doLink o_files = do
 727     verb       <- getVerbFlag
 728     static     <- readIORef v_Static
 729     no_hs_main <- readIORef v_NoHsMain
 730
 731     o_file <- readIORef v_Output_file
 732     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
 733
 734     pkg_lib_paths <- getPackageLibraryPath
 735     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
 736
 737     lib_paths <- readIORef v_Library_paths
 738     let lib_path_opts = map ("-L"++) lib_paths
 739
 740     pkg_libs <- getPackageLibraries
 741     let imp          = if static then "" else "_imp"
 742         pkg_lib_opts = map (\lib -> "-l" ++ lib ++ imp) pkg_libs
 743
 744     libs <- readIORef v_Cmdline_libraries
 745     let lib_opts = map ("-l"++) (reverse libs)
 746          -- reverse because they're added in reverse order from the cmd line
 747
 748     pkg_extra_ld_opts <- getPackageExtraLdOpts
 749
 750         -- probably _stub.o files
 751     extra_ld_inputs <- readIORef v_Ld_inputs
 752
 753         -- opts from -optl-<blah>
 754     extra_ld_opts <- getStaticOpts v_Opt_l
 755
 756     rts_pkg <- getPackageDetails ["rts"]
 757     std_pkg <- getPackageDetails ["std"]
 758     let extra_os = if static || no_hs_main
 759                    then []
 760                    else [ head (library_dirs (head rts_pkg)) ++ "/Main.dll_o",
 761                           head (library_dirs (head std_pkg)) ++ "/PrelMain.dll_o" ]
 762
 763     (md_c_flags, _) <- machdepCCOpts
 764     SysTools.runLink ( [verb, "-o", output_fn]
 765                       ++ md_c_flags
 766                       ++ o_files
 767                       ++ extra_os
 768                       ++ extra_ld_inputs
 769                       ++ lib_path_opts
 770                       ++ lib_opts
 771                       ++ pkg_lib_path_opts
 772                       ++ pkg_lib_opts
 773                       ++ pkg_extra_ld_opts
 774                       ++ extra_ld_opts
 775                       ++ if static && not no_hs_main then
 776 #ifdef LEADING_UNDERSCORE
 777                             [ "-u _PrelMain_mainIO_closure" ,
 778                               "-u ___init_PrelMain"]
 779 #else
 780                             [ "-u PrelMain_mainIO_closure" ,
 781                               "-u __init_PrelMain"]
 782 #endif
 783                          else [])
 784
 785     -- parallel only: move binary to another dir -- HWL
 786     ways_ <- readIORef v_Ways
 787     when (WayPar `elem` ways_)
 788          (do success <- run_phase_MoveBinary output_fn
 789              if success then return ()
 790                         else throwDyn (InstallationError ("cannot move binary to PVM dir")))
 791
 792 -----------------------------------------------------------------------------
 793 -- Making a DLL (only for Win32)
 794
 795 doMkDLL :: [String] -> IO ()
 796 doMkDLL o_files = do
 797     verb       <- getVerbFlag
 798     static     <- readIORef v_Static
 799     no_hs_main <- readIORef v_NoHsMain
 800
 801     o_file <- readIORef v_Output_file
 802     let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
 803
 804     pkg_lib_paths <- getPackageLibraryPath
 805     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
 806
 807     lib_paths <- readIORef v_Library_paths
 808     let lib_path_opts = map ("-L"++) lib_paths
 809
 810     pkg_libs <- getPackageLibraries
 811     let imp = if static then "" else "_imp"
 812         pkg_lib_opts = map (\lib -> "-l" ++ lib ++ imp) pkg_libs
 813
 814     libs <- readIORef v_Cmdline_libraries
 815     let lib_opts = map ("-l"++) (reverse libs)
 816          -- reverse because they're added in reverse order from the cmd line
 817
 818     pkg_extra_ld_opts <- getPackageExtraLdOpts
 819
 820         -- probably _stub.o files
 821     extra_ld_inputs <- readIORef v_Ld_inputs
 822
 823         -- opts from -optdll-<blah>
 824     extra_ld_opts <- getStaticOpts v_Opt_dll
 825
 826     rts_pkg <- getPackageDetails ["rts"]
 827     std_pkg <- getPackageDetails ["std"]
 828
 829     let extra_os = if static || no_hs_main
 830                    then []
 831                    else [ head (library_dirs (head rts_pkg)) ++ "/Main.dll_o",
 832                           head (library_dirs (head std_pkg)) ++ "/PrelMain.dll_o" ]
 833
 834     (md_c_flags, _) <- machdepCCOpts
 835     SysTools.runMkDLL
 836          ([ verb, "-o", output_fn ]
 837          ++ md_c_flags
 838          ++ o_files
 839          ++ extra_os
 840          ++ [ "--target=i386-mingw32" ]
 841          ++ extra_ld_inputs
 842          ++ lib_path_opts
 843          ++ lib_opts
 844          ++ pkg_lib_path_opts
 845          ++ pkg_lib_opts
 846          ++ pkg_extra_ld_opts
 847          ++ (case findPS (packString (concat extra_ld_opts)) (packString "--def") of
 848                Nothing -> [ "--export-all" ]
 849                Just _  -> [ "" ])
 850          ++ extra_ld_opts
 851         )
 852
 853 -----------------------------------------------------------------------------
 854 -- Just preprocess a file, put the result in a temp. file (used by the
 855 -- compilation manager during the summary phase).
 856
 857 preprocess :: FilePath -> IO FilePath
 858 preprocess filename =
 859   ASSERT(haskellish_src_file filename)
 860   do restoreDynFlags    -- Restore to state of last save
 861      pipeline <- genPipeline (StopBefore Hsc) ("preprocess") False
 862                              defaultHscLang filename
 863      runPipeline pipeline filename False{-no linking-} False{-no -o flag-}
 864
 865 -----------------------------------------------------------------------------
 866 -- Compile a single module, under the control of the compilation manager.
 867 --
 868 -- This is the interface between the compilation manager and the
 869 -- compiler proper (hsc), where we deal with tedious details like
 870 -- reading the OPTIONS pragma from the source file, and passing the
 871 -- output of hsc through the C compiler.
 872
 873 -- The driver sits between 'compile' and 'hscMain', translating calls
 874 -- to the former into calls to the latter, and results from the latter
 875 -- into results from the former.  It does things like preprocessing
 876 -- the .hs file if necessary, and compiling up the .stub_c files to
 877 -- generate Linkables.
 878
 879 -- NB.  No old interface can also mean that the source has changed.
 880
 881 compile :: GhciMode                -- distinguish batch from interactive
 882         -> ModSummary              -- summary, including source
 883         -> Bool                    -- True <=> source unchanged
 884         -> Bool                    -- True <=> have object
 885         -> Maybe ModIface          -- old interface, if available
 886         -> HomeSymbolTable         -- for home module ModDetails
 887         -> HomeIfaceTable          -- for home module Ifaces
 888         -> PersistentCompilerState -- persistent compiler state
 889         -> IO CompResult
 890
 891 data CompResult
 892    = CompOK   PersistentCompilerState   -- updated PCS
 893               ModDetails  -- new details (HST additions)
 894               ModIface    -- new iface   (HIT additions)
 895               (Maybe Linkable)
 896                        -- new code; Nothing => compilation was not reqd
 897                        -- (old code is still valid)
 898
 899    | CompErrs PersistentCompilerState   -- updated PCS
 900
 901
 902 compile ghci_mode summary source_unchanged have_object
 903         old_iface hst hit pcs = do
 904    dyn_flags <- restoreDynFlags         -- Restore to the state of the last save
 905
 906
 907    showPass dyn_flags
 908         (showSDoc (text "Compiling" <+> ppr (name_of_summary summary)))
 909
 910    let verb       = verbosity dyn_flags
 911    let location   = ms_location summary
 912    let input_fn   = unJust "compile:hs" (ml_hs_file location)
 913    let input_fnpp = unJust "compile:hspp" (ml_hspp_file location)
 914
 915    when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp))
 916
 917    opts <- getOptionsFromSource input_fnpp
 918    processArgs dynamic_flags opts []
 919    dyn_flags <- getDynFlags
 920
 921    let hsc_lang      = hscLang dyn_flags
 922        (basename, _) = splitFilename input_fn
 923
 924    output_fn <- case hsc_lang of
 925                     HscAsm         -> newTempName (phaseInputExt As)
 926                     HscC           -> newTempName (phaseInputExt HCc)
 927                     HscJava        -> newTempName "java" -- ToDo
 928                     HscILX         -> return (basename ++ ".ilx")       -- newTempName "ilx"    -- ToDo
 929                     HscInterpreted -> return (error "no output file")
 930
 931    let dyn_flags' = dyn_flags { hscOutName = output_fn,
 932                                 hscStubCOutName = basename ++ "_stub.c",
 933                                 hscStubHOutName = basename ++ "_stub.h",
 934                                 extCoreName = basename ++ ".core" }
 935
 936    -- figure out which header files to #include in a generated .hc file
 937    c_includes <- getPackageCIncludes
 938    cmdline_includes <- dynFlag cmdlineHcIncludes -- -#include options
 939
 940    let cc_injects = unlines (map mk_include
 941                                  (c_includes ++ reverse cmdline_includes))
 942        mk_include h_file =
 943         case h_file of
 944            '"':_{-"-} -> "#include "++h_file
 945            '<':_      -> "#include "++h_file
 946            _          -> "#include \""++h_file++"\""
 947
 948    writeIORef v_HCHeader cc_injects
 949
 950    -- run the compiler
 951    hsc_result <- hscMain ghci_mode dyn_flags'
 952                          (ms_mod summary) location
 953                          source_unchanged have_object old_iface hst hit pcs
 954
 955    case hsc_result of
 956       HscFail pcs -> return (CompErrs pcs)
 957
 958       HscNoRecomp pcs details iface -> return (CompOK pcs details iface Nothing)
 959
 960       HscRecomp pcs details iface
 961         stub_h_exists stub_c_exists maybe_interpreted_code -> do
 962
 963            let
 964            maybe_stub_o <- compileStub dyn_flags' stub_c_exists
 965            let stub_unlinked = case maybe_stub_o of
 966                                   Nothing -> []
 967                                   Just stub_o -> [ DotO stub_o ]
 968
 969            (hs_unlinked, unlinked_time) <-
 970              case hsc_lang of
 971
 972                 -- in interpreted mode, just return the compiled code
 973                 -- as our "unlinked" object.
 974                 HscInterpreted ->
 975                     case maybe_interpreted_code of
 976                        Just (bcos,itbl_env) -> do tm <- getClockTime
 977                                                   return ([BCOs bcos itbl_env], tm)
 978                        Nothing -> panic "compile: no interpreted code"
 979
 980                 -- we're in batch mode: finish the compilation pipeline.
 981                 _other -> do pipe <- genPipeline (StopBefore Ln) "" True
 982                                         hsc_lang output_fn
 983                              -- runPipeline takes input_fn so it can split off
 984                              -- the base name and use it as the base of
 985                              -- the output object file.
 986                              let (basename, suffix) = splitFilename input_fn
 987                              o_file <- pipeLoop pipe output_fn False False
 988                                                 basename suffix
 989                              o_time <- getModificationTime o_file
 990                              return ([DotO o_file], o_time)
 991
 992            let linkable = LM unlinked_time (moduleName (ms_mod summary))
 993                              (hs_unlinked ++ stub_unlinked)
 994
 995            return (CompOK pcs details iface (Just linkable))
 996
 997
 998 -----------------------------------------------------------------------------
 999 -- stub .h and .c files (for foreign export support)
1000
1001 compileStub dflags stub_c_exists
1002   | not stub_c_exists = return Nothing
1003   | stub_c_exists = do
1004         -- compile the _stub.c file w/ gcc
1005         let stub_c = hscStubCOutName dflags
1006         pipeline <- genPipeline (StopBefore Ln) "" True defaultHscLang stub_c
1007         stub_o <- runPipeline pipeline stub_c False{-no linking-}
1008                         False{-no -o option-}
1009
1010         return (Just stub_o)