ghc/compiler/main/DriverPipeline.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverPipeline.hs,v 1.37 2000/12/05 12:15:19 rrt 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 ++ '.':phase_input_ext 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 -> return False;
 474
 475             HscRecomp pcs details iface maybe_stub_h maybe_stub_c
 476                       _maybe_interpreted_code -> do
 477
 478             -- deal with stubs
 479         maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
 480         case maybe_stub_o of
 481                 Nothing -> return ()
 482                 Just stub_o -> add v_Ld_inputs stub_o
 483
 484         return True
 485     }
 486
 487 -----------------------------------------------------------------------------
 488 -- Cc phase
 489
 490 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 491 -- way too many hacks, and I can't say I've ever used it anyway.
 492
 493 run_phase cc_phase _basename _suff input_fn output_fn
 494    | cc_phase == Cc || cc_phase == HCc
 495    = do cc <- readIORef v_Pgm_c
 496         cc_opts <- (getOpts opt_c)
 497         cmdline_include_dirs <- readIORef v_Include_paths
 498
 499         let hcc = cc_phase == HCc
 500
 501                 -- add package include paths even if we're just compiling
 502                 -- .c files; this is the Value Add(TM) that using
 503                 -- ghc instead of gcc gives you :)
 504         pkg_include_dirs <- getPackageIncludePath
 505         let include_paths = map (\p -> "-I"++p) (cmdline_include_dirs
 506                                                         ++ pkg_include_dirs)
 507
 508         c_includes <- getPackageCIncludes
 509         cmdline_includes <- readState cmdline_hc_includes -- -#include options
 510
 511         let cc_injects | hcc = unlines (map mk_include
 512                                         (c_includes ++ reverse cmdline_includes))
 513                        | otherwise = ""
 514             mk_include h_file =
 515                 case h_file of
 516                    '"':_{-"-} -> "#include "++h_file
 517                    '<':_      -> "#include "++h_file
 518                    _          -> "#include \""++h_file++"\""
 519
 520         cc_help <- newTempName "c"
 521         h <- openFile cc_help WriteMode
 522         hPutStr h cc_injects
 523         hPutStrLn h ("#include \"" ++ input_fn ++ "\"\n")
 524         hClose h
 525
 526         ccout <- newTempName "ccout"
 527
 528         mangle <- readIORef v_Do_asm_mangling
 529         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
 530
 531         verb <- getVerbFlag
 532
 533         o2 <- readIORef v_minus_o2_for_C
 534         let opt_flag | o2        = "-O2"
 535                      | otherwise = "-O"
 536
 537         pkg_extra_cc_opts <- getPackageExtraCcOpts
 538
 539         split_objs <- readIORef v_Split_object_files
 540         let split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
 541                       | otherwise         = [ ]
 542
 543         excessPrecision <- readIORef v_Excess_precision
 544
 545         runSomething "C Compiler"
 546          (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
 547                    ++ md_c_flags
 548                    ++ (if cc_phase == HCc && mangle
 549                          then md_regd_c_flags
 550                          else [])
 551                    ++ [ verb, "-S", "-Wimplicit", opt_flag ]
 552                    ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 553                    ++ cc_opts
 554                    ++ split_opt
 555                    ++ (if excessPrecision then [] else [ "-ffloat-store" ])
 556                    ++ include_paths
 557                    ++ pkg_extra_cc_opts
 558 --                 ++ [">", ccout]
 559                    ))
 560         return True
 561
 562         -- ToDo: postprocess the output from gcc
 563
 564 -----------------------------------------------------------------------------
 565 -- Mangle phase
 566
 567 run_phase Mangle _basename _suff input_fn output_fn
 568   = do mangler <- readIORef v_Pgm_m
 569        mangler_opts <- getOpts opt_m
 570        machdep_opts <-
 571          if (prefixMatch "i386" cTARGETPLATFORM)
 572             then do n_regs <- readState stolen_x86_regs
 573                     return [ show n_regs ]
 574             else return []
 575        runSomething "Assembly Mangler"
 576         (unwords (mangler :
 577                      mangler_opts
 578                   ++ [ input_fn, output_fn ]
 579                   ++ machdep_opts
 580                 ))
 581        return True
 582
 583 -----------------------------------------------------------------------------
 584 -- Splitting phase
 585
 586 run_phase SplitMangle _basename _suff input_fn _output_fn
 587   = do  splitter <- readIORef v_Pgm_s
 588
 589         -- this is the prefix used for the split .s files
 590         tmp_pfx <- readIORef v_TmpDir
 591         x <- myGetProcessID
 592         let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
 593         writeIORef v_Split_prefix split_s_prefix
 594         addFilesToClean [split_s_prefix ++ "__*"] -- d:-)
 595
 596         -- allocate a tmp file to put the no. of split .s files in (sigh)
 597         n_files <- newTempName "n_files"
 598
 599         runSomething "Split Assembly File"
 600          (unwords [ splitter
 601                   , input_fn
 602                   , split_s_prefix
 603                   , n_files ]
 604          )
 605
 606         -- save the number of split files for future references
 607         s <- readFile n_files
 608         let n = read s :: Int
 609         writeIORef v_N_split_files n
 610         return True
 611
 612 -----------------------------------------------------------------------------
 613 -- As phase
 614
 615 run_phase As _basename _suff input_fn output_fn
 616   = do  as <- readIORef v_Pgm_a
 617         as_opts <- getOpts opt_a
 618
 619         cmdline_include_paths <- readIORef v_Include_paths
 620         let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
 621         runSomething "Assembler"
 622            (unwords (as : as_opts
 623                        ++ cmdline_include_flags
 624                        ++ [ "-c", input_fn, "-o",  output_fn ]
 625                     ))
 626         return True
 627
 628 run_phase SplitAs basename _suff _input_fn _output_fn
 629   = do  as <- readIORef v_Pgm_a
 630         as_opts <- getOpts opt_a
 631
 632         split_s_prefix <- readIORef v_Split_prefix
 633         n <- readIORef v_N_split_files
 634
 635         odir <- readIORef v_Output_dir
 636         let real_odir = case odir of
 637                                 Nothing -> basename
 638                                 Just d  -> d
 639
 640         let assemble_file n = do
 641                     let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
 642                     let output_o = newdir real_odir
 643                                         (basename ++ "__" ++ show n ++ ".o")
 644                     real_o <- osuf_ify output_o
 645                     runSomething "Assembler"
 646                             (unwords (as : as_opts
 647                                       ++ [ "-c", "-o", real_o, input_s ]
 648                             ))
 649
 650         mapM_ assemble_file [1..n]
 651         return True
 652
 653 -----------------------------------------------------------------------------
 654 -- Linking
 655
 656 GLOBAL_VAR(no_hs_main, False, Bool)
 657
 658 doLink :: [String] -> IO ()
 659 doLink o_files = do
 660     ln <- readIORef v_Pgm_l
 661     verb <- getVerbFlag
 662     static <- readIORef v_Static
 663     let imp = if static then "" else "_imp"
 664     no_hs_main <- readIORef v_NoHsMain
 665
 666     o_file <- readIORef v_Output_file
 667     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
 668
 669     pkg_lib_paths <- getPackageLibraryPath
 670     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
 671
 672     lib_paths <- readIORef v_Library_paths
 673     let lib_path_opts = map ("-L"++) lib_paths
 674
 675     pkg_libs <- getPackageLibraries
 676     let pkg_lib_opts = map (\lib -> "-l" ++ lib ++ imp) pkg_libs
 677
 678     libs <- readIORef v_Cmdline_libraries
 679     let lib_opts = map ("-l"++) (reverse libs)
 680          -- reverse because they're added in reverse order from the cmd line
 681
 682     pkg_extra_ld_opts <- getPackageExtraLdOpts
 683
 684         -- probably _stub.o files
 685     extra_ld_inputs <- readIORef v_Ld_inputs
 686
 687         -- opts from -optl-<blah>
 688     extra_ld_opts <- getStaticOpts v_Opt_l
 689
 690     rts_pkg <- getPackageDetails ["rts"]
 691     std_pkg <- getPackageDetails ["std"]
 692 #ifdef mingw32_TARGET_OS
 693     let extra_os = if static || no_hs_main
 694                    then []
 695 --                   else [ head (lib_paths (head rts_pkg)) ++ "/Main.dll_o",
 696 --                          head (lib_paths (head std_pkg)) ++ "/PrelMain.dll_o" ]
 697                      else []
 698 #endif
 699     (md_c_flags, _) <- machdepCCOpts
 700     runSomething "Linker"
 701        (unwords
 702          ([ ln, verb, "-o", output_fn ]
 703          ++ md_c_flags
 704          ++ o_files
 705 #ifdef mingw32_TARGET_OS
 706          ++ extra_os
 707 #endif
 708          ++ extra_ld_inputs
 709          ++ lib_path_opts
 710          ++ lib_opts
 711          ++ pkg_lib_path_opts
 712          ++ pkg_lib_opts
 713          ++ pkg_extra_ld_opts
 714          ++ extra_ld_opts
 715 #ifdef mingw32_TARGET_OS
 716          ++ if static then [ "-u _PrelMain_mainIO_closure" , "-u ___init_PrelMain"] else []
 717 #else
 718          ++ [ "-u PrelMain_mainIO_closure" , "-u __init_PrelMain"]
 719 #endif
 720         )
 721        )
 722
 723 -----------------------------------------------------------------------------
 724 -- Just preprocess a file, put the result in a temp. file (used by the
 725 -- compilation manager during the summary phase).
 726
 727 preprocess :: FilePath -> IO FilePath
 728 preprocess filename =
 729   ASSERT(haskellish_file filename)
 730   do init_driver_state <- readIORef v_InitDriverState
 731      writeIORef v_Driver_state init_driver_state
 732
 733      pipeline <- genPipeline (StopBefore Hsc) ("preprocess") False
 734                         defaultHscLang filename
 735      runPipeline pipeline filename False{-no linking-} False{-no -o flag-}
 736
 737
 738 -----------------------------------------------------------------------------
 739 -- Compile a single module, under the control of the compilation manager.
 740 --
 741 -- This is the interface between the compilation manager and the
 742 -- compiler proper (hsc), where we deal with tedious details like
 743 -- reading the OPTIONS pragma from the source file, and passing the
 744 -- output of hsc through the C compiler.
 745
 746 -- The driver sits between 'compile' and 'hscMain', translating calls
 747 -- to the former into calls to the latter, and results from the latter
 748 -- into results from the former.  It does things like preprocessing
 749 -- the .hs file if necessary, and compiling up the .stub_c files to
 750 -- generate Linkables.
 751
 752 -- NB.  No old interface can also mean that the source has changed.
 753
 754 compile :: GhciMode                -- distinguish batch from interactive
 755         -> ModSummary              -- summary, including source
 756         -> Bool                    -- source unchanged?
 757         -> Maybe ModIface          -- old interface, if available
 758         -> HomeSymbolTable         -- for home module ModDetails
 759         -> HomeIfaceTable          -- for home module Ifaces
 760         -> PersistentCompilerState -- persistent compiler state
 761         -> IO CompResult
 762
 763 data CompResult
 764    = CompOK   PersistentCompilerState   -- updated PCS
 765               ModDetails  -- new details (HST additions)
 766               ModIface    -- new iface   (HIT additions)
 767               (Maybe Linkable)
 768                        -- new code; Nothing => compilation was not reqd
 769                        -- (old code is still valid)
 770
 771    | CompErrs PersistentCompilerState   -- updated PCS
 772
 773
 774 compile ghci_mode summary source_unchanged old_iface hst hit pcs = do
 775    init_dyn_flags <- readIORef v_InitDynFlags
 776    writeIORef v_DynFlags init_dyn_flags
 777    init_driver_state <- readIORef v_InitDriverState
 778    writeIORef v_Driver_state init_driver_state
 779
 780    showPass init_dyn_flags
 781         (showSDoc (text "Compiling" <+> ppr (name_of_summary summary)))
 782
 783    let verb = verbosity init_dyn_flags
 784    let location   = ms_location summary
 785    let input_fn   = unJust "compile:hs" (ml_hs_file location)
 786    let input_fnpp = unJust "compile:hspp" (ml_hspp_file location)
 787
 788    when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp))
 789
 790    opts <- getOptionsFromSource input_fnpp
 791    processArgs dynamic_flags opts []
 792    dyn_flags <- readIORef v_DynFlags
 793
 794    let hsc_lang = hscLang dyn_flags
 795    output_fn <- case hsc_lang of
 796                     HscAsm         -> newTempName (phaseInputExt As)
 797                     HscC           -> newTempName (phaseInputExt HCc)
 798                     HscJava        -> newTempName "java" -- ToDo
 799                     HscInterpreted -> return (error "no output file")
 800
 801    -- run the compiler
 802    hsc_result <- hscMain ghci_mode dyn_flags{ hscOutName = output_fn }
 803                          source_unchanged
 804                          location old_iface hst hit pcs
 805
 806    case hsc_result of
 807       HscFail pcs -> return (CompErrs pcs)
 808
 809       HscNoRecomp pcs details iface -> return (CompOK pcs details iface Nothing)
 810
 811       HscRecomp pcs details iface
 812         maybe_stub_h maybe_stub_c maybe_interpreted_code -> do
 813
 814            let (basename, _) = splitFilename input_fn
 815            maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
 816            let stub_unlinked = case maybe_stub_o of
 817                                   Nothing -> []
 818                                   Just stub_o -> [ DotO stub_o ]
 819
 820            (hs_unlinked, unlinked_time) <-
 821              case hsc_lang of
 822
 823                 -- in interpreted mode, just return the compiled code
 824                 -- as our "unlinked" object.
 825                 HscInterpreted ->
 826                     case maybe_interpreted_code of
 827                        Just (code,itbl_env) -> do tm <- getClockTime
 828                                                   return ([Trees code itbl_env], tm)
 829                        Nothing -> panic "compile: no interpreted code"
 830
 831                 -- we're in batch mode: finish the compilation pipeline.
 832                 _other -> do pipe <- genPipeline (StopBefore Ln) "" True
 833                                         hsc_lang output_fn
 834                              -- runPipeline takes input_fn so it can split off
 835                              -- the base name and use it as the base of
 836                              -- the output object file.
 837                              let (basename, suffix) = splitFilename input_fn
 838                              o_file <- pipeLoop pipe output_fn False False
 839                                                 basename suffix
 840                              o_time <- getModificationTime o_file
 841                              return ([DotO o_file], o_time)
 842
 843            let linkable = LM unlinked_time (moduleName (ms_mod summary))
 844                              (hs_unlinked ++ stub_unlinked)
 845
 846            return (CompOK pcs details iface (Just linkable))
 847
 848
 849 -----------------------------------------------------------------------------
 850 -- stub .h and .c files (for foreign export support)
 851
 852 dealWithStubs basename maybe_stub_h maybe_stub_c
 853
 854  = do   let stub_h = basename ++ "_stub.h"
 855         let stub_c = basename ++ "_stub.c"
 856
 857   -- copy the .stub_h file into the current dir if necessary
 858         case maybe_stub_h of
 859            Nothing -> return ()
 860            Just tmp_stub_h -> do
 861                 runSomething "Copy stub .h file"
 862                                 ("cp " ++ tmp_stub_h ++ ' ':stub_h)
 863
 864                         -- #include <..._stub.h> in .hc file
 865                 addCmdlineHCInclude tmp_stub_h  -- hack
 866
 867   -- copy the .stub_c file into the current dir, and compile it, if necessary
 868         case maybe_stub_c of
 869            Nothing -> return Nothing
 870            Just tmp_stub_c -> do  -- copy the _stub.c file into the current dir
 871                 runSomething "Copy stub .c file"
 872                     (unwords [
 873                         "rm -f", stub_c, "&&",
 874                         "echo \'#include \"Stg.h\"\n#include \""++stub_h++"\"\' >"++stub_c, " &&",
 875                         "cat", tmp_stub_c, ">> ", stub_c
 876                         ])
 877
 878                         -- compile the _stub.c file w/ gcc
 879                 pipeline <- genPipeline (StopBefore Ln) "" True
 880                                 defaultHscLang stub_c
 881                 stub_o <- runPipeline pipeline stub_c False{-no linking-}
 882                                 False{-no -o option-}
 883
 884                 return (Just stub_o)