ghc/compiler/main/DriverPipeline.hs

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