ghc/compiler/main/DriverPipeline.hs

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