ghc/driver/Main.hs

   1 -----------------------------------------------------------------------------
   2 -- GHC Driver program
   3 --
   4 -- (c) Simon Marlow 2000
   5 --
   6 -----------------------------------------------------------------------------
   7
   8 module Main (main) where
   9
  10 import Package
  11 import Config
  12
  13 import RegexString
  14 import Concurrent
  15 import Posix
  16 import IOExts
  17 import Exception
  18 import Dynamic
  19
  20 import IO
  21 import Array
  22 import List
  23 import System
  24 import Maybe
  25 import Char
  26
  27 #define GLOBAL_VAR(name,value,ty)  \
  28 name = global (value) :: IORef (ty); \
  29 {-# NOINLINE name #-}
  30
  31 -----------------------------------------------------------------------------
  32 -- ToDo:
  33
  34 -- time commands when run with -v
  35 -- split marker
  36 -- mkDLL
  37 -- java generation
  38 -- user ways
  39 -- Win32 support
  40 -- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too
  41
  42 -----------------------------------------------------------------------------
  43 -- Differences vs. old driver:
  44
  45 -- No more "Enter your Haskell program, end with ^D (on a line of its own):"
  46 -- consistency checking removed (may do this properly later)
  47 -- removed -noC
  48 -- no hi diffs (could be added later)
  49 -- no -Ofile
  50
  51 -----------------------------------------------------------------------------
  52 -- non-configured things
  53
  54 _Haskell1Version = "5" -- i.e., Haskell 98
  55
  56 -----------------------------------------------------------------------------
  57 -- Usage Message
  58
  59 short_usage = do
  60   hPutStr stderr "\nUsage: For basic information, try the `-help' option.\n"
  61   exitWith ExitSuccess
  62
  63 long_usage = do
  64   let usage_filename = "ghc-usage.txt"
  65       usage_dir = findFile usage_filename cGHC_DRIVER_DIR
  66   usage <- readFile (usage_dir ++ "/" ++ usage_filename)
  67   dump usage
  68   exitWith ExitSuccess
  69   where
  70      dump "" = return ()
  71      dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s
  72      dump (c:s) = hPutChar stderr c >> dump s
  73
  74 version_str = cProjectVersion ++
  75                 ( if cProjectPatchLevel /= "0" && cProjectPatchLevel /= ""
  76                         then '.':cProjectPatchLevel
  77                         else "")
  78
  79 -----------------------------------------------------------------------------
  80 -- Phases
  81
  82 {-
  83 Phase of the           | Suffix saying | Flag saying   | (suffix of)
  84 compilation system     | ``start here''| ``stop after''| output file
  85
  86 literate pre-processor | .lhs          | -             | -
  87 C pre-processor (opt.) | -             | -E            | -
  88 Haskell compiler       | .hs           | -C, -S        | .hc, .s
  89 C compiler (opt.)      | .hc or .c     | -S            | .s
  90 assembler              | .s  or .S     | -c            | .o
  91 linker                 | other         | -             | a.out
  92 -}
  93
  94 data Phase
  95         = MkDependHS    -- haskell dependency generation
  96         | Unlit
  97         | Cpp
  98         | Hsc
  99         | Cc
 100         | HCc           -- Haskellised C (as opposed to vanilla C) compilation
 101         | Mangle        -- assembly mangling, now done by a separate script.
 102         | SplitMangle   -- after mangler if splitting
 103         | SplitAs
 104         | As
 105         | Ln
 106   deriving (Eq,Ord,Enum,Ix,Show,Bounded)
 107
 108 initial_phase = Unlit
 109
 110 -----------------------------------------------------------------------------
 111 -- Errors
 112
 113 data BarfKind
 114   = UnknownFileType String
 115   | UnknownFlag String
 116   | AmbiguousPhase
 117   | MultipleSrcsOneOutput
 118   | UnknownPackage String
 119   | WayCombinationNotSupported [WayName]
 120   | PhaseFailed String ExitCode
 121   | Interrupted
 122   | NoInputFiles
 123   deriving Eq
 124
 125 GLOBAL_VAR(prog_name, "ghc", String)
 126
 127 get_prog_name = unsafePerformIO (readIORef prog_name) -- urk!
 128
 129 instance Show BarfKind where
 130   showsPrec _ e
 131         = showString get_prog_name . showString ": " . showBarf e
 132
 133 showBarf AmbiguousPhase
 134    = showString "only one of the flags -M, -E, -C, -S, -c is allowed"
 135 showBarf (UnknownFileType s)
 136    = showString "unknown file type, and linking not done: " . showString s
 137 showBarf (UnknownFlag s)
 138    = showString "unrecognised flag: " . showString s
 139 showBarf MultipleSrcsOneOutput
 140    = showString "can't apply -o option to multiple source files"
 141 showBarf (UnknownPackage s)
 142    = showString "unknown package name: " . showString s
 143 showBarf (WayCombinationNotSupported ws)
 144    = showString "combination not supported: "
 145    . foldr1 (\a b -> a . showChar '/' . b)
 146         (map (showString . wayName . lkupWay) ws)
 147 showBarf (NoInputFiles)
 148    = showString "no input files"
 149
 150 barfKindTc = mkTyCon "BarfKind"
 151
 152 instance Typeable BarfKind where
 153   typeOf _ = mkAppTy barfKindTc []
 154
 155 -----------------------------------------------------------------------------
 156 -- Temporary files
 157
 158 GLOBAL_VAR(files_to_clean, [], [String])
 159
 160 cleanTempFiles :: IO ()
 161 cleanTempFiles = do
 162   fs <- readIORef files_to_clean
 163   verb <- readIORef verbose
 164
 165   let blowAway f =
 166            (do  on verb (hPutStrLn stderr ("removing: " ++ f))
 167                 if '*' `elem` f then system ("rm -f " ++ f) >> return ()
 168                                 else removeLink f)
 169             `catchAllIO`
 170            (\e -> on verb (hPutStrLn stderr
 171                                 ("warning: can't remove tmp file" ++ f)))
 172   mapM_ blowAway fs
 173
 174 -----------------------------------------------------------------------------
 175 -- Which phase to stop at
 176
 177 GLOBAL_VAR(stop_after, Ln, Phase)
 178
 179 end_phase_flag :: String -> Maybe Phase
 180 end_phase_flag "-M" = Just MkDependHS
 181 end_phase_flag "-E" = Just Cpp
 182 end_phase_flag "-C" = Just Hsc
 183 end_phase_flag "-S" = Just Mangle
 184 end_phase_flag "-c" = Just As
 185 end_phase_flag _    = Nothing
 186
 187 getStopAfter :: [String]
 188          -> IO ( [String]   -- rest of command line
 189                , Phase      -- stop after phase
 190                , Bool       -- do linking?
 191                )
 192 getStopAfter flags
 193   = case my_partition end_phase_flag flags of
 194         ([]   , rest) -> return (rest, As,  True)
 195         ([one], rest) -> return (rest, one, False)
 196         (_    , rest) -> throwDyn AmbiguousPhase
 197
 198 -----------------------------------------------------------------------------
 199 -- Global compilation flags
 200
 201         -- Cpp-related flags
 202 GLOBAL_VAR(cpp_flag, False, Bool)
 203 hs_source_cpp_opts = global
 204         [ "-D__HASKELL1__="++_Haskell1Version
 205         , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
 206         , "-D__HASKELL98__"
 207         , "-D__CONCURRENT_HASKELL__"
 208         ]
 209
 210         -- Keep output from intermediate phases
 211 GLOBAL_VAR(keep_hi_diffs,       False,          Bool)
 212 GLOBAL_VAR(keep_hc_files,       False,          Bool)
 213 GLOBAL_VAR(keep_s_files,        False,          Bool)
 214 GLOBAL_VAR(keep_raw_s_files,    False,          Bool)
 215
 216         -- Compiler RTS options
 217 GLOBAL_VAR(specific_heap_size,  6 * 1000 * 1000, Integer)
 218 GLOBAL_VAR(specific_stack_size, 1000 * 1000,     Integer)
 219 GLOBAL_VAR(scale_sizes_by,      1.0,             Double)
 220
 221         -- Verbose
 222 GLOBAL_VAR(verbose, False, Bool)
 223 is_verbose = do v <- readIORef verbose; if v then return "-v" else return ""
 224
 225         -- Misc
 226 GLOBAL_VAR(dry_run,             False,          Bool)
 227 GLOBAL_VAR(recomp,              True,           Bool)
 228 GLOBAL_VAR(tmp_prefix,          cTMPDIR,        String)
 229 GLOBAL_VAR(stolen_x86_regs,     4,              Int)
 230 GLOBAL_VAR(static,              True,           Bool)  -- ToDo: not for mingw32
 231 GLOBAL_VAR(collect_ghc_timing,  False,          Bool)
 232 GLOBAL_VAR(do_asm_mangling,     True,           Bool)
 233
 234 -----------------------------------------------------------------------------
 235 -- Splitting object files (for libraries)
 236
 237 GLOBAL_VAR(split_object_files,  False,          Bool)
 238 GLOBAL_VAR(split_prefix,        "",             String)
 239 GLOBAL_VAR(n_split_files,       0,              Int)
 240
 241 can_split :: Bool
 242 can_split =  prefixMatch "i386" cTARGETPLATFORM
 243           || prefixMatch "alpha" cTARGETPLATFORM
 244           || prefixMatch "hppa" cTARGETPLATFORM
 245           || prefixMatch "m68k" cTARGETPLATFORM
 246           || prefixMatch "mips" cTARGETPLATFORM
 247           || prefixMatch "powerpc" cTARGETPLATFORM
 248           || prefixMatch "rs6000" cTARGETPLATFORM
 249           || prefixMatch "sparc" cTARGETPLATFORM
 250
 251 -----------------------------------------------------------------------------
 252 -- Compiler output options
 253
 254 data HscLang
 255   = HscC
 256   | HscAsm
 257   | HscJava
 258
 259 GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" &&
 260                          prefixMatch "i386" cTARGETPLATFORM
 261                         then  HscAsm
 262                         else  HscC,
 263            HscLang)
 264
 265 GLOBAL_VAR(output_dir,  Nothing, Maybe String)
 266 GLOBAL_VAR(output_suf,  Nothing, Maybe String)
 267 GLOBAL_VAR(output_file, Nothing, Maybe String)
 268 GLOBAL_VAR(output_hi,   Nothing, Maybe String)
 269
 270 GLOBAL_VAR(ld_inputs,   [],      [String])
 271
 272 odir_ify :: String -> IO String
 273 odir_ify f = do
 274   odir_opt <- readIORef output_dir
 275   case odir_opt of
 276         Nothing -> return f
 277         Just d  -> return (newdir d f)
 278
 279 osuf_ify :: String -> IO String
 280 osuf_ify f = do
 281   osuf_opt <- readIORef output_suf
 282   case osuf_opt of
 283         Nothing -> return f
 284         Just s  -> return (newsuf s f)
 285
 286 -----------------------------------------------------------------------------
 287 -- Hi Files
 288
 289 GLOBAL_VAR(produceHi,           True,   Bool)
 290 GLOBAL_VAR(hi_on_stdout,        False,  Bool)
 291 GLOBAL_VAR(hi_with,             "",     String)
 292 GLOBAL_VAR(hi_suf,              "hi",   String)
 293
 294 data HiDiffFlag = NormalHiDiffs | UsageHiDiffs | NoHiDiffs
 295 GLOBAL_VAR(hi_diffs, NoHiDiffs, HiDiffFlag)
 296
 297 -----------------------------------------------------------------------------
 298 -- Warnings & sanity checking
 299
 300 -- Warning packages that are controlled by -W and -Wall.  The 'standard'
 301 -- warnings that you get all the time are
 302 --
 303 --         -fwarn-overlapping-patterns
 304 --         -fwarn-missing-methods
 305 --         -fwarn-missing-fields
 306 --         -fwarn-deprecations
 307 --         -fwarn-duplicate-exports
 308 --
 309 -- these are turned off by -Wnot.
 310
 311 standardWarnings  = [ "-fwarn-overlapping-patterns"
 312                     , "-fwarn-missing-methods"
 313                     , "-fwarn-missing-fields"
 314                     , "-fwarn-deprecations"
 315                     , "-fwarn-duplicate-exports"
 316                     ]
 317 minusWOpts        = standardWarnings ++
 318                     [ "-fwarn-unused-binds"
 319                     , "-fwarn-unused-matches"
 320                     , "-fwarn-incomplete-patterns"
 321                     , "-fwarn-unused-imports"
 322                     ]
 323 minusWallOpts     = minusWOpts ++
 324                     [ "-fwarn-type-defaults"
 325                     , "-fwarn-name-shadowing"
 326                     , "-fwarn-missing-signatures"
 327                     ]
 328
 329 data WarningState = W_default | W_ | W_all | W_not
 330
 331 GLOBAL_VAR(warning_opt, W_default, WarningState)
 332
 333 -----------------------------------------------------------------------------
 334 -- Compiler optimisation options
 335
 336 GLOBAL_VAR(opt_level, 0, Int)
 337
 338 setOptLevel :: String -> IO ()
 339 setOptLevel ""              = do { writeIORef opt_level 1; go_via_C }
 340 setOptLevel "not"           = writeIORef opt_level 0
 341 setOptLevel [c] | isDigit c = do
 342    let level = ord c - ord '0'
 343    writeIORef opt_level level
 344    on (level >= 1) go_via_C
 345 setOptLevel s = throwDyn (UnknownFlag ("-O"++s))
 346
 347 go_via_C = do
 348    l <- readIORef hsc_lang
 349    case l of { HscAsm -> writeIORef hsc_lang HscC;
 350                _other -> return () }
 351
 352 GLOBAL_VAR(opt_minus_o2_for_C, False, Bool)
 353
 354 GLOBAL_VAR(opt_MaxSimplifierIterations, 4, Int)
 355 GLOBAL_VAR(opt_StgStats,    False, Bool)
 356 GLOBAL_VAR(opt_UsageSPInf,  False, Bool)  -- Off by default
 357
 358 hsc_minusO2_flags = hsc_minusO_flags    -- for now
 359
 360 hsc_minusNoO_flags = do
 361   iter        <- readIORef opt_MaxSimplifierIterations
 362   return [
 363         "-fignore-interface-pragmas",
 364         "-fomit-interface-pragmas",
 365         "-fsimplify",
 366             "[",
 367                 "-fmax-simplifier-iterations" ++ show iter,
 368             "]"
 369         ]
 370
 371 hsc_minusO_flags = do
 372   iter       <- readIORef opt_MaxSimplifierIterations
 373   usageSP    <- readIORef opt_UsageSPInf
 374   stgstats   <- readIORef opt_StgStats
 375
 376   return [
 377         "-ffoldr-build-on",
 378
 379         "-fdo-eta-reduction",
 380         "-fdo-lambda-eta-expansion",
 381         "-fcase-of-case",
 382         "-fcase-merge",
 383         "-flet-to-case",
 384
 385         -- initial simplify: mk specialiser happy: minimum effort please
 386
 387         "-fsimplify",
 388           "[",
 389                 "-finline-phase0",
 390                         -- Don't inline anything till full laziness has bitten
 391                         -- In particular, inlining wrappers inhibits floating
 392                         -- e.g. ...(case f x of ...)...
 393                         --  ==> ...(case (case x of I# x# -> fw x#) of ...)...
 394                         --  ==> ...(case x of I# x# -> case fw x# of ...)...
 395                         -- and now the redex (f x) isn't floatable any more
 396
 397                 "-fno-rules",
 398                         -- Similarly, don't apply any rules until after full
 399                         -- laziness.  Notably, list fusion can prevent floating.
 400
 401                 "-fno-case-of-case",
 402                         -- Don't do case-of-case transformations.
 403                         -- This makes full laziness work better
 404
 405                 "-fmax-simplifier-iterations2",
 406           "]",
 407
 408         -- Specialisation is best done before full laziness
 409         -- so that overloaded functions have all their dictionary lambdas manifest
 410         "-fspecialise",
 411
 412         "-ffloat-outwards",
 413         "-ffloat-inwards",
 414
 415         "-fsimplify",
 416           "[",
 417                 "-finline-phase1",
 418                 -- Want to run with inline phase 1 after the specialiser to give
 419                 -- maximum chance for fusion to work before we inline build/augment
 420                 -- in phase 2.  This made a difference in 'ansi' where an
 421                 -- overloaded function wasn't inlined till too late.
 422                 "-fmax-simplifier-iterations" ++ show iter,
 423           "]",
 424
 425         -- infer usage information here in case we need it later.
 426         -- (add more of these where you need them --KSW 1999-04)
 427         if usageSP then "-fusagesp" else "",
 428
 429         "-fsimplify",
 430           "[",
 431                 -- Need inline-phase2 here so that build/augment get
 432                 -- inlined.  I found that spectral/hartel/genfft lost some useful
 433                 -- strictness in the function sumcode' if augment is not inlined
 434                 -- before strictness analysis runs
 435
 436                 "-finline-phase2",
 437                 "-fmax-simplifier-iterations2",
 438           "]",
 439
 440
 441         "-fsimplify",
 442           "[",
 443                 "-fmax-simplifier-iterations2",
 444                 -- No -finline-phase: allow all Ids to be inlined now
 445                 -- This gets foldr inlined before strictness analysis
 446           "]",
 447
 448         "-fstrictness",
 449         "-fcpr-analyse",
 450         "-fworker-wrapper",
 451
 452         "-fsimplify",
 453           "[",
 454                 "-fmax-simplifier-iterations" ++ show iter,
 455                 -- No -finline-phase: allow all Ids to be inlined now
 456           "]",
 457
 458         "-ffloat-outwards",
 459                 -- nofib/spectral/hartel/wang doubles in speed if you
 460                 -- do full laziness late in the day.  It only happens
 461                 -- after fusion and other stuff, so the early pass doesn't
 462                 -- catch it.  For the record, the redex is
 463                 --        f_el22 (f_el21 r_midblock)
 464
 465 -- Leave out lambda lifting for now
 466 --        "-fsimplify", -- Tidy up results of full laziness
 467 --          "[",
 468 --                "-fmax-simplifier-iterations2",
 469 --          "]",
 470 --        "-ffloat-outwards-full",
 471
 472         -- We want CSE to follow the final full-laziness pass, because it may
 473         -- succeed in commoning up things floated out by full laziness.
 474         --
 475         -- CSE must immediately follow a simplification pass, because it relies
 476         -- on the no-shadowing invariant.  See comments at the top of CSE.lhs
 477         -- So it must NOT follow float-inwards, which can give rise to shadowing,
 478         -- even if its input doesn't have shadows.  Hence putting it between
 479         -- the two passes.
 480         "-fcse",
 481
 482
 483         "-ffloat-inwards",
 484
 485 -- Case-liberation for -O2.  This should be after
 486 -- strictness analysis and the simplification which follows it.
 487
 488 --        ( ($OptLevel != 2)
 489 --        ? ""
 490 --        : "-fliberate-case -fsimplify [ $Oopt_FB_Support -ffloat-lets-exposing-whnf -ffloat-primops-ok -fcase-of-case -fdo-case-elim -fcase-merge -fdo-lambda-eta-expansion -freuse-con -flet-to-case $Oopt_PedanticBottoms $Oopt_MaxSimplifierIterations $Oopt_ShowSimplifierProgress ]" ),
 491 --
 492 --        "-fliberate-case",
 493
 494         -- Final clean-up simplification:
 495         "-fsimplify",
 496           "[",
 497                 "-fmax-simplifier-iterations" ++ show iter,
 498                 -- No -finline-phase: allow all Ids to be inlined now
 499           "]"
 500
 501         ]
 502
 503 -----------------------------------------------------------------------------
 504 -- Paths & Libraries
 505
 506 split_marker = ':'   -- not configurable
 507
 508 import_paths, include_paths, library_paths :: IORef [String]
 509 GLOBAL_VAR(import_paths,  ["."], [String])
 510 GLOBAL_VAR(include_paths, ["."], [String])
 511 GLOBAL_VAR(library_paths, [],    [String])
 512
 513 GLOBAL_VAR(cmdline_libraries,   [], [String])
 514 GLOBAL_VAR(cmdline_hc_includes, [], [String])
 515
 516 augment_import_paths :: String -> IO ()
 517 augment_import_paths "" = writeIORef import_paths []
 518 augment_import_paths path
 519   = do paths <- readIORef import_paths
 520        writeIORef import_paths (paths ++ dirs)
 521   where dirs = split split_marker path
 522
 523 augment_include_paths :: String -> IO ()
 524 augment_include_paths path
 525   = do paths <- readIORef include_paths
 526        writeIORef include_paths (paths ++ split split_marker path)
 527
 528 augment_library_paths :: String -> IO ()
 529 augment_library_paths path
 530   = do paths <- readIORef library_paths
 531        writeIORef library_paths (paths ++ split split_marker path)
 532
 533 -----------------------------------------------------------------------------
 534 -- Packages
 535
 536 -- package list is maintained in dependency order
 537 packages = global ["std", "rts", "gmp"] :: IORef [String]
 538 -- comma in value, so can't use macro, grrr
 539 {-# NOINLINE packages #-}
 540
 541 addPackage :: String -> IO ()
 542 addPackage package
 543   = do pkg_details <- readIORef package_details
 544        case lookup package pkg_details of
 545           Nothing -> throwDyn (UnknownPackage package)
 546           Just details -> do
 547             ps <- readIORef packages
 548             if package `elem` ps
 549                 then return ()
 550                 else do mapM_ addPackage (package_deps details)
 551                         ps <- readIORef packages
 552                         writeIORef packages (package:ps)
 553
 554 getPackageImportPath   :: IO [String]
 555 getPackageImportPath = do
 556   ps <- readIORef packages
 557   ps' <- getPackageDetails ps
 558   return (nub (concat (map import_dirs ps')))
 559
 560 getPackageIncludePath   :: IO [String]
 561 getPackageIncludePath = do
 562   ps <- readIORef packages
 563   ps' <- getPackageDetails ps
 564   return (nub (filter (not.null) (map include_dir ps')))
 565
 566         -- includes are in reverse dependency order (i.e. rts first)
 567 getPackageCIncludes   :: IO [String]
 568 getPackageCIncludes = do
 569   ps <- readIORef packages
 570   ps' <- getPackageDetails ps
 571   return (reverse (nub (filter (not.null) (map c_include ps'))))
 572
 573 getPackageLibraryPath  :: IO [String]
 574 getPackageLibraryPath = do
 575   ps <- readIORef packages
 576   ps' <- getPackageDetails ps
 577   return (nub (concat (map library_dirs ps')))
 578
 579 getPackageLibraries    :: IO [String]
 580 getPackageLibraries = do
 581   ps <- readIORef packages
 582   ps' <- getPackageDetails ps
 583   tag <- readIORef build_tag
 584   let suffix = if null tag then "" else '_':tag
 585   return (concat (map libraries ps'))
 586
 587 getPackageExtraGhcOpts :: IO [String]
 588 getPackageExtraGhcOpts = do
 589   ps <- readIORef packages
 590   ps' <- getPackageDetails ps
 591   return (map extra_ghc_opts ps')
 592
 593 getPackageExtraCcOpts  :: IO [String]
 594 getPackageExtraCcOpts = do
 595   ps <- readIORef packages
 596   ps' <- getPackageDetails ps
 597   return (map extra_cc_opts ps')
 598
 599 getPackageExtraLdOpts  :: IO [String]
 600 getPackageExtraLdOpts = do
 601   ps <- readIORef packages
 602   ps' <- getPackageDetails ps
 603   return (map extra_ld_opts ps')
 604
 605 getPackageDetails ps = do
 606   pkg_details <- readIORef package_details
 607   let getDetails p =  case lookup p pkg_details of
 608                         Just details -> return details
 609                         Nothing -> error "getPackageDetails"
 610   mapM getDetails ps
 611
 612 GLOBAL_VAR(package_details, (error "package_details"), [(String,Package)])
 613
 614 -----------------------------------------------------------------------------
 615 -- Ways
 616
 617 -- The central concept of a "way" is that all objects in a given
 618 -- program must be compiled in the same "way".  Certain options change
 619 -- parameters of the virtual machine, eg. profiling adds an extra word
 620 -- to the object header, so profiling objects cannot be linked with
 621 -- non-profiling objects.
 622
 623 -- After parsing the command-line options, we determine which "way" we
 624 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
 625
 626 -- We then find the "build-tag" associated with this way, and this
 627 -- becomes the suffix used to find .hi files and libraries used in
 628 -- this compilation.
 629
 630 GLOBAL_VAR(build_tag, "", String)
 631
 632 data WayName
 633   = WayProf
 634   | WayUnreg
 635   | WayTicky
 636   | WayPar
 637   | WayGran
 638   | WaySMP
 639   | WayDebug
 640   | WayUser_a
 641   | WayUser_b
 642   | WayUser_c
 643   | WayUser_d
 644   | WayUser_e
 645   | WayUser_f
 646   | WayUser_g
 647   | WayUser_h
 648   | WayUser_i
 649   | WayUser_j
 650   | WayUser_k
 651   | WayUser_l
 652   | WayUser_m
 653   | WayUser_n
 654   | WayUser_o
 655   | WayUser_A
 656   | WayUser_B
 657   deriving (Eq,Ord)
 658
 659 GLOBAL_VAR(ways, [] ,[WayName])
 660
 661 allowed_combinations =
 662    [  [WayProf,WayUnreg],
 663       [WayProf,WaySMP]     -- works???
 664    ]
 665
 666 findBuildTag :: IO [String]  -- new options
 667 findBuildTag = do
 668   way_names <- readIORef ways
 669   case sort way_names of
 670      []  -> do  writeIORef build_tag ""
 671                 return []
 672
 673      [w] -> do let details = lkupWay w
 674                writeIORef build_tag (wayTag details)
 675                return (wayOpts details)
 676
 677      ws  -> if  ws `notElem` allowed_combinations
 678                 then throwDyn (WayCombinationNotSupported ws)
 679                 else let stuff = map lkupWay ws
 680                          tag   = concat (map wayTag stuff)
 681                          flags = map wayOpts stuff
 682                      in do
 683                      writeIORef build_tag tag
 684                      return (concat flags)
 685
 686 lkupWay w =
 687    case lookup w way_details of
 688         Nothing -> error "findBuildTag"
 689         Just details -> details
 690
 691 data Way = Way {
 692   wayTag   :: String,
 693   wayName  :: String,
 694   wayOpts  :: [String]
 695   }
 696
 697 way_details :: [ (WayName, Way) ]
 698 way_details =
 699   [ (WayProf, Way  "p" "Profiling"
 700         [ "-fscc-profiling"
 701         , "-DPROFILING"
 702         , "-optc-DPROFILING" ]),
 703
 704     (WayTicky, Way  "t" "Ticky-ticky Profiling"
 705         [ "-fticky-ticky"
 706         , "-DTICKY_TICKY"
 707         , "-optc-DTICKY_TICKY" ]),
 708
 709     (WayUnreg, Way  "u" "Unregisterised"
 710         [ "-optc-DNO_REGS"
 711         , "-optc-DUSE_MINIINTERPRETER"
 712         , "-fno-asm-mangling"
 713         , "-funregisterised" ]),
 714
 715     (WayPar, Way  "mp" "Parallel"
 716         [ "-fstack-check"
 717         , "-fparallel"
 718         , "-D__PARALLEL_HASKELL__"
 719         , "-optc-DPAR"
 720         , "-package concurrent" ]),
 721
 722     (WayGran, Way  "mg" "Gransim"
 723         [ "-fstack-check"
 724         , "-fgransim"
 725         , "-D__GRANSIM__"
 726         , "-optc-DGRAN"
 727         , "-package concurrent" ]),
 728
 729     (WaySMP, Way  "s" "SMP"
 730         [ "-fsmp"
 731         , "-optc-pthread"
 732         , "-optl-pthread"
 733         , "-optc-DSMP" ]),
 734
 735     (WayUser_a,  Way  "a"  "User way 'a'"  ["$WAY_a_REAL_OPTS"]),
 736     (WayUser_b,  Way  "b"  "User way 'b'"  ["$WAY_b_REAL_OPTS"]),
 737     (WayUser_c,  Way  "c"  "User way 'c'"  ["$WAY_c_REAL_OPTS"]),
 738     (WayUser_d,  Way  "d"  "User way 'd'"  ["$WAY_d_REAL_OPTS"]),
 739     (WayUser_e,  Way  "e"  "User way 'e'"  ["$WAY_e_REAL_OPTS"]),
 740     (WayUser_f,  Way  "f"  "User way 'f'"  ["$WAY_f_REAL_OPTS"]),
 741     (WayUser_g,  Way  "g"  "User way 'g'"  ["$WAY_g_REAL_OPTS"]),
 742     (WayUser_h,  Way  "h"  "User way 'h'"  ["$WAY_h_REAL_OPTS"]),
 743     (WayUser_i,  Way  "i"  "User way 'i'"  ["$WAY_i_REAL_OPTS"]),
 744     (WayUser_j,  Way  "j"  "User way 'j'"  ["$WAY_j_REAL_OPTS"]),
 745     (WayUser_k,  Way  "k"  "User way 'k'"  ["$WAY_k_REAL_OPTS"]),
 746     (WayUser_l,  Way  "l"  "User way 'l'"  ["$WAY_l_REAL_OPTS"]),
 747     (WayUser_m,  Way  "m"  "User way 'm'"  ["$WAY_m_REAL_OPTS"]),
 748     (WayUser_n,  Way  "n"  "User way 'n'"  ["$WAY_n_REAL_OPTS"]),
 749     (WayUser_o,  Way  "o"  "User way 'o'"  ["$WAY_o_REAL_OPTS"]),
 750     (WayUser_A,  Way  "A"  "User way 'A'"  ["$WAY_A_REAL_OPTS"]),
 751     (WayUser_B,  Way  "B"  "User way 'B'"  ["$WAY_B_REAL_OPTS"])
 752   ]
 753
 754 -----------------------------------------------------------------------------
 755 -- Programs for particular phases
 756
 757 GLOBAL_VAR(pgm_dep, findFile "mkdependHS" cGHC_MKDEPENDHS, String)
 758 GLOBAL_VAR(pgm_L,   findFile "unlit"      cGHC_UNLIT,      String)
 759 GLOBAL_VAR(pgm_P,   cRAWCPP,                               String)
 760 GLOBAL_VAR(pgm_C,   findFile "hsc"        cGHC_HSC,        String)
 761 GLOBAL_VAR(pgm_c,   cGCC,                                  String)
 762 GLOBAL_VAR(pgm_m,   findFile "ghc-asm"    cGHC_MANGLER,    String)
 763 GLOBAL_VAR(pgm_s,   findFile "ghc-split"  cGHC_SPLIT,      String)
 764 GLOBAL_VAR(pgm_a,   cGCC,                                  String)
 765 GLOBAL_VAR(pgm_l,   cGCC,                                  String)
 766
 767 -----------------------------------------------------------------------------
 768 -- Options for particular phases
 769
 770 GLOBAL_VAR(opt_dep, [], [String])
 771 GLOBAL_VAR(opt_L, [], [String])
 772 GLOBAL_VAR(opt_P, [], [String])
 773 GLOBAL_VAR(opt_C, [], [String])
 774 GLOBAL_VAR(opt_Crts, [], [String])
 775 GLOBAL_VAR(opt_c, [], [String])
 776 GLOBAL_VAR(opt_a, [], [String])
 777 GLOBAL_VAR(opt_m, [], [String])
 778 GLOBAL_VAR(opt_l, [], [String])
 779 GLOBAL_VAR(opt_dll, [], [String])
 780
 781         -- we add to the options from the front, so we need to reverse the list
 782 getOpts :: IORef [String] -> IO [String]
 783 getOpts opts = readIORef opts >>= return . reverse
 784
 785 GLOBAL_VAR(anti_opt_C, [], [String])
 786
 787 -----------------------------------------------------------------------------
 788 -- Via-C compilation stuff
 789
 790 -- flags returned are: ( all C compilations
 791 --                     , registerised HC compilations
 792 --                     )
 793
 794 machdepCCOpts
 795    | prefixMatch "alpha"   cTARGETPLATFORM
 796         = return ( ["-static"], [] )
 797
 798    | prefixMatch "hppa"    cTARGETPLATFORM
 799         -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
 800         -- (very nice, but too bad the HP /usr/include files don't agree.)
 801         = return ( ["-static", "-D_HPUX_SOURCE"], [] )
 802
 803    | prefixMatch "m68k"    cTARGETPLATFORM
 804       -- -fno-defer-pop : for the .hc files, we want all the pushing/
 805       --    popping of args to routines to be explicit; if we let things
 806       --    be deferred 'til after an STGJUMP, imminent death is certain!
 807       --
 808       -- -fomit-frame-pointer : *don't*
 809       --     It's better to have a6 completely tied up being a frame pointer
 810       --     rather than let GCC pick random things to do with it.
 811       --     (If we want to steal a6, then we would try to do things
 812       --     as on iX86, where we *do* steal the frame pointer [%ebp].)
 813         = return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
 814
 815    | prefixMatch "i386"    cTARGETPLATFORM
 816       -- -fno-defer-pop : basically the same game as for m68k
 817       --
 818       -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
 819       --   the fp (%ebp) for our register maps.
 820         = do n_regs <- readIORef stolen_x86_regs
 821              sta    <- readIORef static
 822              return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" ],
 823                       [ "-fno-defer-pop", "-fomit-frame-pointer",
 824                         "-DSTOLEN_X86_REGS="++show n_regs ]
 825                     )
 826
 827    | prefixMatch "mips"    cTARGETPLATFORM
 828         = return ( ["static"], [] )
 829
 830    | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
 831         = return ( ["static"], ["-finhibit-size-directive"] )
 832
 833    | otherwise
 834         = return ( [], [] )
 835
 836 -----------------------------------------------------------------------------
 837 -- Build the Hsc command line
 838
 839 build_hsc_opts :: IO [String]
 840 build_hsc_opts = do
 841   opt_C_ <- getOpts opt_C               -- misc hsc opts
 842
 843         -- warnings
 844   warn_level <- readIORef warning_opt
 845   let warn_opts =  case warn_level of
 846                         W_default -> standardWarnings
 847                         W_        -> minusWOpts
 848                         W_all     -> minusWallOpts
 849                         W_not     -> []
 850
 851         -- optimisation
 852   minus_o <- readIORef opt_level
 853   optimisation_opts <-
 854         case minus_o of
 855             0 -> hsc_minusNoO_flags
 856             1 -> hsc_minusO_flags
 857             2 -> hsc_minusO2_flags
 858             -- ToDo: -Ofile
 859
 860         -- STG passes
 861   ways_ <- readIORef ways
 862   let stg_massage | WayProf `elem` ways_ =  "-fmassage-stg-for-profiling"
 863                   | otherwise            = ""
 864
 865   stg_stats <- readIORef opt_StgStats
 866   let stg_stats_flag | stg_stats = "-dstg-stats"
 867                      | otherwise = ""
 868
 869   let stg_opts = [ stg_massage, stg_stats_flag, "-flet-no-escape" ]
 870         -- let-no-escape always on for now
 871
 872   verb <- is_verbose
 873   let hi_vers = "-fhi-version="++cProjectVersionInt
 874   static <- (do s <- readIORef static; if s then return "-static" else return "")
 875
 876   l <- readIORef hsc_lang
 877   let lang = case l of
 878                 HscC    -> "-olang=C"
 879                 HscAsm  -> "-olang=asm"
 880                 HscJava -> "-olang=java"
 881
 882   -- get hi-file suffix
 883   hisuf <- readIORef hi_suf
 884
 885   -- hi-suffix for packages depends on the build tag.
 886   package_hisuf <-
 887         do tag <- readIORef build_tag
 888            if null tag
 889                 then return "hi"
 890                 else return (tag ++ "_hi")
 891
 892   import_dirs <- readIORef import_paths
 893   package_import_dirs <- getPackageImportPath
 894
 895   let hi_map = "-himap=" ++
 896                 makeHiMap import_dirs hisuf
 897                          package_import_dirs package_hisuf
 898                          split_marker
 899
 900       hi_map_sep = "-himap-sep=" ++ [split_marker]
 901
 902   scale <- readIORef scale_sizes_by
 903   heap  <- readIORef specific_heap_size
 904   stack <- readIORef specific_stack_size
 905   cmdline_rts_opts <- getOpts opt_Crts
 906   let heap'  = truncate (fromIntegral heap  * scale) :: Integer
 907       stack' = truncate (fromIntegral stack * scale) :: Integer
 908       rts_opts = [ "+RTS", "-H"++show heap', "-K"++show stack' ]
 909                  ++ cmdline_rts_opts ++ [ "-RTS" ]
 910
 911   -- take into account -fno-* flags by removing the equivalent -f*
 912   -- flag from our list.
 913   anti_flags <- getOpts anti_opt_C
 914   let basic_opts = opt_C_ ++ warn_opts ++ optimisation_opts ++ stg_opts
 915       filtered_opts = filter (`notElem` anti_flags) basic_opts
 916
 917   return
 918         (
 919         filtered_opts
 920         -- ToDo: C stub files
 921         ++ [ hi_vers, static, verb, lang, hi_map, hi_map_sep ]
 922         ++ rts_opts
 923         )
 924
 925 makeHiMap
 926   (import_dirs         :: [String])
 927   (hi_suffix           :: String)
 928   (package_import_dirs :: [String])
 929   (package_hi_suffix   :: String)
 930   (split_marker        :: Char)
 931   = foldr (add_dir hi_suffix)
 932         (foldr (add_dir package_hi_suffix) "" package_import_dirs)
 933         import_dirs
 934   where
 935      add_dir hisuf dir str = dir ++ "%." ++ hisuf ++ split_marker : str
 936
 937
 938 getOptionsFromSource
 939         :: String               -- input file
 940         -> IO [String]          -- options, if any
 941 getOptionsFromSource file
 942   = do h <- openFile file ReadMode
 943        look h
 944   where
 945         look h = do
 946             l <- hGetLine h
 947             case () of
 948                 () | null l -> look h
 949                    | prefixMatch "#" l -> look h
 950                    | prefixMatch "{-# LINE" l -> look h
 951                    | Just (opts:_) <- matchRegex optionRegex l
 952                         -> return (words opts)
 953                    | otherwise -> return []
 954
 955 optionRegex = mkRegex "{-#[ \t]+OPTIONS[ \t]+(.*)#-}"
 956
 957 -----------------------------------------------------------------------------
 958 -- Main loop
 959
 960 get_source_files :: [String] -> ([String],[String])
 961 get_source_files = partition (('-' /=) . head)
 962
 963 suffixes :: [(String,Phase)]
 964 suffixes =
 965   [ ("lhs",   Unlit)
 966   , ("hs",    Cpp)
 967   , ("hc",    HCc)
 968   , ("c",     Cc)
 969   , ("raw_s", Mangle)
 970   , ("s",     As)
 971   , ("S",     As)
 972   , ("o",     Ln)
 973   ]
 974
 975 phase_input_ext Unlit       = "lhs"
 976 phase_input_ext Cpp         = "lpp"
 977 phase_input_ext Hsc         = "cpp"
 978 phase_input_ext HCc         = "hc"
 979 phase_input_ext Cc          = "c"
 980 phase_input_ext Mangle      = "raw_s"
 981 phase_input_ext SplitMangle = "split_s" -- not really generated
 982 phase_input_ext As          = "s"
 983 phase_input_ext SplitAs     = "split_s" -- not really generated
 984 phase_input_ext Ln          = "o"
 985
 986 find_phase :: String -> ([(Phase,String)], [String])
 987    -> ([(Phase,String)], [String])
 988 find_phase f (phase_srcs, unknown_srcs)
 989   = case lookup ext suffixes of
 990         Just the_phase -> ((the_phase,f):phase_srcs, unknown_srcs)
 991         Nothing        -> (phase_srcs, f:unknown_srcs)
 992   where (basename,ext) = split_filename f
 993
 994
 995 find_phases srcs = (phase_srcs, unknown_srcs)
 996   where (phase_srcs, unknown_srcs) = foldr find_phase ([],[]) srcs
 997
 998 main =
 999   -- all error messages are propagated as exceptions
1000   my_catchDyn (\dyn -> case dyn of
1001                           PhaseFailed phase code -> exitWith code
1002                           Interrupted -> exitWith (ExitFailure 1)
1003                           _ -> do hPutStrLn stderr (show (dyn :: BarfKind))
1004                                   exitWith (ExitFailure 1)) $
1005
1006   later cleanTempFiles $
1007         -- exceptions will be blocked while we clean the temporary files,
1008         -- so there shouldn't be any difficulty if we receive further
1009         -- signals.
1010
1011   do
1012         -- install signal handlers
1013    main_thread <- myThreadId
1014    let sig_handler = Catch (raiseInThread main_thread
1015                                 (DynException (toDyn Interrupted)))
1016    installHandler sigQUIT sig_handler Nothing
1017    installHandler sigINT  sig_handler Nothing
1018
1019    pgm    <- getProgName
1020    writeIORef prog_name pgm
1021
1022    argv   <- getArgs
1023
1024    -- grab any -B options from the command line first
1025    argv'  <- setTopDir argv
1026
1027    -- read the package configuration
1028    let conf = findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")
1029    contents <- readFile conf
1030    writeIORef package_details (read contents)
1031
1032    -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
1033    (flags2, stop_phase, do_linking) <- getStopAfter argv'
1034
1035    -- process all the other arguments, and get the source files
1036    srcs   <- processArgs flags2 []
1037
1038    -- find the build tag, and re-process the build-specific options
1039    more_opts <- findBuildTag
1040    _ <- processArgs more_opts []
1041
1042    if stop_phase == MkDependHS          -- mkdependHS is special
1043         then do_mkdependHS flags2 srcs
1044         else do
1045
1046    -- for each source file, find which phase to start at
1047    let (phase_srcs, unknown_srcs) = find_phases srcs
1048
1049    o_file <- readIORef output_file
1050    if isJust o_file && not do_linking && length phase_srcs > 1
1051         then throwDyn MultipleSrcsOneOutput
1052         else do
1053
1054    if null unknown_srcs && null phase_srcs
1055         then throwDyn NoInputFiles
1056         else do
1057
1058    -- if we have unknown files, and we're not doing linking, complain
1059    -- (otherwise pass them through to the linker).
1060    if not (null unknown_srcs) && not do_linking
1061         then throwDyn (UnknownFileType (head unknown_srcs))
1062         else do
1063
1064    let  compileFile :: (Phase, String) -> IO String
1065         compileFile (phase, src) = do
1066           let (orig_base, _) = split_filename src
1067           if phase < Ln -- anything to do?
1068                 then run_pipeline stop_phase do_linking True orig_base (phase,src)
1069                 else return src
1070
1071    o_files <- mapM compileFile phase_srcs
1072
1073    if do_linking
1074         then do_link o_files unknown_srcs
1075         else return ()
1076
1077
1078 -- The following compilation pipeline algorithm is fairly hacky.  A
1079 -- better way to do this would be to express the whole comilation as a
1080 -- data flow DAG, where the nodes are the intermediate files and the
1081 -- edges are the compilation phases.  This framework would also work
1082 -- nicely if a haskell dependency generator was included in the
1083 -- driver.
1084
1085 -- It would also deal much more cleanly with compilation phases that
1086 -- generate multiple intermediates, (eg. hsc generates .hc, .hi, and
1087 -- possibly stub files), where some of the output files need to be
1088 -- processed further (eg. the stub files need to be compiled by the C
1089 -- compiler).
1090
1091 -- A cool thing to do would then be to execute the data flow graph
1092 -- concurrently, automatically taking advantage of extra processors on
1093 -- the host machine.  For example, when compiling two Haskell files
1094 -- where one depends on the other, the data flow graph would determine
1095 -- that the C compiler from the first comilation can be overlapped
1096 -- with the hsc comilation for the second file.
1097
1098 run_pipeline
1099   :: Phase              -- phase to end on (never Linker)
1100   -> Bool               -- doing linking afterward?
1101   -> Bool               -- take into account -o when generating output?
1102   -> String             -- original basename (eg. Main)
1103   -> (Phase, String)    -- phase to run, input file
1104   -> IO String          -- return final filename
1105
1106 run_pipeline last_phase do_linking use_ofile orig_basename (phase, input_fn)
1107   | phase > last_phase = return input_fn
1108   | otherwise
1109   = do
1110
1111      let (basename,ext) = split_filename input_fn
1112
1113      split  <- readIORef split_object_files
1114      mangle <- readIORef do_asm_mangling
1115      lang   <- readIORef hsc_lang
1116
1117         -- figure out what the next phase is.  This is
1118         -- straightforward, apart from the fact that hsc can generate
1119         -- either C or assembler direct, and assembly mangling is
1120         -- optional, and splitting involves one extra phase and an alternate
1121         -- assembler.
1122      let next_phase =
1123           case phase of
1124                 Hsc -> case lang of
1125                             HscC   -> HCc
1126                             HscAsm -> As
1127
1128                 HCc  | mangle    -> Mangle
1129                      | otherwise -> As
1130
1131                 Cc -> As
1132
1133                 Mangle | not split -> As
1134                 SplitMangle -> SplitAs
1135                 SplitAs -> Ln
1136
1137                 _  -> succ phase
1138
1139
1140         -- filename extension for the output, determined by next_phase
1141      let new_ext = phase_input_ext next_phase
1142
1143         -- Figure out what the output from this pass should be called.
1144
1145         -- If we're keeping the output from this phase, then we just save
1146         -- it in the current directory, otherwise we generate a new temp file.
1147      keep_s <- readIORef keep_s_files
1148      keep_raw_s <- readIORef keep_raw_s_files
1149      keep_hc <- readIORef keep_hc_files
1150      let keep_this_output =
1151            case next_phase of
1152                 Ln -> True
1153                 Mangle | keep_raw_s -> True -- first enhancement :)
1154                 As | keep_s  -> True
1155                 Cc | keep_hc -> True
1156                 _other -> False
1157
1158      output_fn <-
1159         (if phase == last_phase && not do_linking && use_ofile
1160             then do o_file <- readIORef output_file
1161                     case o_file of
1162                         Just s  -> return s
1163                         Nothing -> do
1164                             f <- odir_ify (orig_basename ++ '.':new_ext)
1165                             osuf_ify f
1166
1167                 -- .o files are always kept.  .s files and .hc file may be kept.
1168             else if keep_this_output
1169                         then odir_ify (orig_basename ++ '.':new_ext)
1170                         else do filename <- newTempName new_ext
1171                                 add files_to_clean filename
1172                                 return filename
1173         )
1174
1175      run_phase phase orig_basename input_fn output_fn
1176
1177         -- sadly, ghc -E is supposed to write the file to stdout.  We
1178         -- generate <file>.cpp, so we also have to cat the file here.
1179      if (next_phase > last_phase && last_phase == Cpp)
1180         then run_something "Dump pre-processed file to stdout"
1181                 ("cat " ++ output_fn)
1182         else return ()
1183
1184      run_pipeline last_phase do_linking use_ofile
1185           orig_basename (next_phase, output_fn)
1186
1187
1188 -- find a temporary name that doesn't already exist.
1189 newTempName :: String -> IO String
1190 newTempName extn = do
1191   x <- getProcessID
1192   tmp_dir <- readIORef tmp_prefix
1193   findTempName tmp_dir x
1194   where findTempName tmp_dir x = do
1195            let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
1196            b  <- fileExist filename
1197            if b then findTempName tmp_dir (x+1)
1198                 else return filename
1199
1200 -------------------------------------------------------------------------------
1201 -- mkdependHS phase
1202
1203 do_mkdependHS :: [String] -> [String] -> IO ()
1204 do_mkdependHS cmd_opts srcs = do
1205
1206     --  # They're not (currently) needed, but we need to quote any -#include options
1207     -- foreach (@Cmd_opts) {
1208     --     s/-#include.*$/'$&'/g;
1209     -- };
1210
1211    mkdependHS      <- readIORef pgm_dep
1212    mkdependHS_opts <- getOpts opt_dep
1213    hs_src_cpp_opts <- readIORef hs_source_cpp_opts
1214
1215    run_something "Dependency generation"
1216         (unwords (mkdependHS :
1217                       mkdependHS_opts
1218                    ++ hs_src_cpp_opts
1219                    ++ ("--" : cmd_opts )
1220                    ++ ("--" : srcs)
1221         ))
1222
1223 -------------------------------------------------------------------------------
1224 -- Unlit phase
1225
1226 run_phase Unlit basename input_fn output_fn
1227   = do unlit <- readIORef pgm_L
1228        unlit_flags <- getOpts opt_L
1229        run_something "Literate pre-processor"
1230           ("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
1231            ++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
1232
1233 -------------------------------------------------------------------------------
1234 -- Cpp phase
1235
1236 run_phase Cpp basename input_fn output_fn
1237   = do src_opts <- getOptionsFromSource input_fn
1238        processArgs src_opts []
1239
1240        do_cpp <- readIORef cpp_flag
1241        if do_cpp
1242           then do
1243             cpp <- readIORef pgm_P
1244             hscpp_opts <- getOpts opt_P
1245             hs_src_cpp_opts <- readIORef hs_source_cpp_opts
1246
1247             cmdline_include_paths <- readIORef include_paths
1248             pkg_include_dirs <- getPackageIncludePath
1249             let include_paths = map (\p -> "-I"++p) (cmdline_include_paths
1250                                                         ++ pkg_include_dirs)
1251
1252             verb <- is_verbose
1253             run_something "C pre-processor"
1254                 (unwords
1255                    (["echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}'", ">", output_fn, "&&",
1256                      cpp, verb]
1257                     ++ include_paths
1258                     ++ hs_src_cpp_opts
1259                     ++ hscpp_opts
1260                     ++ [ "-x", "c", input_fn, ">>", output_fn ]
1261                    ))
1262           else do
1263             run_something "Inefective C pre-processor"
1264                    ("echo '{-# LINE 1 \""  ++ input_fn ++ "\" -}' > "
1265                     ++ output_fn ++ " && cat " ++ input_fn
1266                     ++ " >> " ++ output_fn)
1267
1268 -----------------------------------------------------------------------------
1269 -- Hsc phase
1270
1271 run_phase Hsc   basename input_fn output_fn
1272   = do  hsc <- readIORef pgm_C
1273
1274   -- we add the current directory (i.e. the directory in which
1275   -- the .hs files resides) to the import path, since this is
1276   -- what gcc does, and it's probably what you want.
1277         let current_dir = getdir basename
1278
1279         paths <- readIORef include_paths
1280         writeIORef include_paths (current_dir : paths)
1281
1282   -- build the hsc command line
1283         hsc_opts <- build_hsc_opts
1284
1285         doing_hi <- readIORef produceHi
1286         tmp_hi_file <- if doing_hi
1287                           then do fn <- newTempName "hi"
1288                                   add files_to_clean fn
1289                                   return fn
1290                           else return ""
1291
1292         let hi_flag = if doing_hi then "-hifile=" ++ tmp_hi_file
1293                                   else ""
1294
1295   -- deal with -Rghc-timing
1296         timing <- readIORef collect_ghc_timing
1297         stat_file <- newTempName "stat"
1298         add files_to_clean stat_file
1299         let stat_opts | timing    = [ "+RTS", "-S"++stat_file, "-RTS" ]
1300                       | otherwise = []
1301
1302   -- tmp files for foreign export stub code
1303         tmp_stub_h <- newTempName "stub_h"
1304         tmp_stub_c <- newTempName "stub_c"
1305         add files_to_clean tmp_stub_h
1306         add files_to_clean tmp_stub_c
1307
1308   -- figure out where to put the .hi file
1309         ohi    <- readIORef output_hi
1310         hisuf  <- readIORef hi_suf
1311         let hi_flags = case ohi of
1312                            Nothing -> [ "-hidir="++current_dir, "-hisuf="++hisuf ]
1313                            Just fn -> [ "-hifile="++fn ]
1314
1315   -- run the compiler!
1316         run_something "Haskell Compiler"
1317                  (unwords (hsc : input_fn : (
1318                     hsc_opts
1319                     ++ hi_flags
1320                     ++ [
1321                           "-ofile="++output_fn,
1322                           "-F="++tmp_stub_c,
1323                           "-FH="++tmp_stub_h
1324                        ]
1325                     ++ stat_opts
1326                  )))
1327
1328   -- Generate -Rghc-timing info
1329         on (timing) (
1330             run_something "Generate timing stats"
1331                 (findFile "ghc-stats" cGHC_STATS ++ ' ':stat_file)
1332          )
1333
1334   -- Deal with stubs
1335         let stub_h = basename ++ "_stub.h"
1336         let stub_c = basename ++ "_stub.c"
1337
1338                 -- copy .h_stub file into current dir if present
1339         b <- fileExist tmp_stub_h
1340         on b (do
1341                 run_something "Copy stub .h file"
1342                                 ("cp " ++ tmp_stub_h ++ ' ':stub_h)
1343
1344                         -- #include <..._stub.h> in .hc file
1345                 add cmdline_hc_includes tmp_stub_h      -- hack
1346
1347                         -- copy the _stub.c file into the current dir
1348                 run_something "Copy stub .c file"
1349                     (unwords [
1350                         "rm -f", stub_c, "&&",
1351                         "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
1352                         "cat", tmp_stub_c, ">> ", stub_c
1353                         ])
1354
1355                         -- compile the _stub.c file w/ gcc
1356                 run_pipeline As False{-no linking-}
1357                                 False{-no -o option-}
1358                                 (basename++"_stub")
1359                                 (Cc, stub_c)
1360
1361                 add ld_inputs (basename++"_stub.o")
1362          )
1363
1364 -----------------------------------------------------------------------------
1365 -- Cc phase
1366
1367 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
1368 -- way too many hacks, and I can't say I've ever used it anyway.
1369
1370 run_phase cc_phase basename input_fn output_fn
1371    | cc_phase == Cc || cc_phase == HCc
1372    = do cc <- readIORef pgm_c
1373         cc_opts <- getOpts opt_c
1374         cmdline_include_dirs <- readIORef include_paths
1375        -- ToDo: $c_flags .= " -mno-cygwin" if ( $TargetPlatform =~ /-mingw32$/ );
1376
1377         let hcc = cc_phase == HCc
1378
1379                 -- add package include paths even if we're just compiling
1380                 -- .c files; this is the Value Add(TM) that using
1381                 -- ghc instead of gcc gives you :)
1382         pkg_include_dirs <- getPackageIncludePath
1383         let include_paths = map (\p -> "-I"++p) (cmdline_include_dirs
1384                                                         ++ pkg_include_dirs)
1385
1386         c_includes <- getPackageCIncludes
1387         cmdline_includes <- readIORef cmdline_hc_includes -- -#include options
1388
1389         let cc_injects | hcc = unlines (map mk_include
1390                                         (c_includes ++ reverse cmdline_includes))
1391                        | otherwise = ""
1392             mk_include h_file =
1393                 case h_file of
1394                    '"':_{-"-} -> "#include "++h_file
1395                    '<':_      -> "#include "++h_file
1396                    _          -> "#include \""++h_file++"\""
1397
1398         cc_help <- newTempName "c"
1399         add files_to_clean cc_help
1400         h <- openFile cc_help WriteMode
1401         hPutStr h cc_injects
1402         hPutStrLn h ("#include \"" ++ input_fn ++ "\"\n")
1403         hClose h
1404
1405         ccout <- newTempName "ccout"
1406         add files_to_clean ccout
1407
1408         mangle <- readIORef do_asm_mangling
1409         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
1410
1411         verb <- is_verbose
1412
1413         o2 <- readIORef opt_minus_o2_for_C
1414         let opt_flag | o2        = "-O2"
1415                      | otherwise = "-O"
1416
1417         pkg_extra_cc_opts <- getPackageExtraCcOpts
1418
1419         run_something "C Compiler"
1420          (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
1421                    ++ md_c_flags
1422                    ++ (if cc_phase == HCc && mangle
1423                          then md_regd_c_flags
1424                          else [])
1425                    ++ [ verb, "-S", "-Wimplicit", opt_flag ]
1426                    ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
1427                    ++ cc_opts
1428                    ++ include_paths
1429                    ++ pkg_extra_cc_opts
1430 --                 ++ [">", ccout]
1431                    ))
1432
1433         -- ToDo: postprocess the output from gcc
1434
1435 -----------------------------------------------------------------------------
1436 -- Mangle phase
1437
1438 run_phase Mangle basename input_fn output_fn
1439   = do mangler <- readIORef pgm_m
1440        mangler_opts <- getOpts opt_m
1441        machdep_opts <-
1442          if (prefixMatch "i386" cTARGETPLATFORM)
1443             then do n_regs <- readIORef stolen_x86_regs
1444                     return [ show n_regs ]
1445             else return []
1446        run_something "Assembly Mangler"
1447         (unwords (mangler :
1448                      mangler_opts
1449                   ++ [ input_fn, output_fn ]
1450                   ++ machdep_opts
1451                 ))
1452
1453 -----------------------------------------------------------------------------
1454 -- Splitting phase
1455
1456 run_phase SplitMangle basename input_fn outputfn
1457   = do  splitter <- readIORef pgm_s
1458
1459         -- this is the prefix used for the split .s files
1460         tmp_pfx <- readIORef tmp_prefix
1461         x <- getProcessID
1462         let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
1463         writeIORef split_prefix split_s_prefix
1464         add files_to_clean (split_s_prefix ++ "__*") -- d:-)
1465
1466         -- allocate a tmp file to put the no. of split .s files in (sigh)
1467         n_files <- newTempName "n_files"
1468         add files_to_clean n_files
1469
1470         run_something "Split Assembly File"
1471          (unwords [ splitter
1472                   , input_fn
1473                   , split_s_prefix
1474                   , n_files ]
1475          )
1476
1477         -- save the number of split files for future references
1478         s <- readFile n_files
1479         let n = read s :: Int
1480         writeIORef n_split_files n
1481
1482 -----------------------------------------------------------------------------
1483 -- As phase
1484
1485 run_phase As basename input_fn output_fn
1486   = do  as <- readIORef pgm_a
1487         as_opts <- getOpts opt_a
1488
1489         cmdline_include_paths <- readIORef include_paths
1490         let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
1491         run_something "Assembler"
1492            (unwords (as : as_opts
1493                        ++ cmdline_include_flags
1494                        ++ [ "-c", input_fn, "-o",  output_fn ]
1495                     ))
1496
1497 run_phase SplitAs basename input_fn output_fn
1498   = do  as <- readIORef pgm_a
1499         as_opts <- getOpts opt_a
1500
1501         odir_opt <- readIORef output_dir
1502         let odir | Just s <- odir_opt = s
1503                      | otherwise          = basename
1504
1505         split_s_prefix <- readIORef split_prefix
1506         n <- readIORef n_split_files
1507
1508         odir <- readIORef output_dir
1509         let real_odir = case odir of
1510                                 Nothing -> basename
1511                                 Just d  -> d
1512
1513         let assemble_file n = do
1514                     let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
1515                     let output_o = newdir real_odir
1516                                         (basename ++ "__" ++ show n ++ ".o")
1517                     real_o <- osuf_ify output_o
1518                     run_something "Assembler"
1519                             (unwords (as : as_opts
1520                                       ++ [ "-c", "-o", real_o, input_s ]
1521                             ))
1522
1523         mapM_ assemble_file [1..n]
1524
1525 -----------------------------------------------------------------------------
1526 -- Linking
1527
1528 do_link :: [String] -> [String] -> IO ()
1529 do_link o_files unknown_srcs = do
1530     ln <- readIORef pgm_l
1531     verb <- is_verbose
1532     o_file <- readIORef output_file
1533     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1534
1535     pkg_lib_paths <- getPackageLibraryPath
1536     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1537
1538     lib_paths <- readIORef library_paths
1539     let lib_path_opts = map ("-L"++) lib_paths
1540
1541     pkg_libs <- getPackageLibraries
1542     let pkg_lib_opts = map ("-l"++) pkg_libs
1543
1544     libs <- readIORef cmdline_libraries
1545     let lib_opts = map ("-l"++) (reverse libs)
1546          -- reverse because they're added in reverse order from the cmd line
1547
1548     pkg_extra_ld_opts <- getPackageExtraLdOpts
1549
1550         -- probably _stub.o files
1551     extra_ld_inputs <- readIORef ld_inputs
1552
1553         -- opts from -optl-<blah>
1554     extra_ld_opts <- getOpts opt_l
1555
1556     run_something "Linker"
1557        (unwords
1558          ([ ln, verb, "-o", output_fn ]
1559          ++ o_files
1560          ++ unknown_srcs
1561          ++ extra_ld_inputs
1562          ++ lib_path_opts
1563          ++ lib_opts
1564          ++ pkg_lib_path_opts
1565          ++ pkg_lib_opts
1566          ++ pkg_extra_ld_opts
1567          ++ extra_ld_opts
1568         )
1569        )
1570
1571 -----------------------------------------------------------------------------
1572 -- Running an external program
1573
1574 run_something phase_name cmd
1575  = do
1576    verb <- readIORef verbose
1577    if verb then do
1578         putStr phase_name
1579         putStrLn ":"
1580         putStrLn cmd
1581      else
1582         return ()
1583
1584    -- test for -n flag
1585    n <- readIORef dry_run
1586    if n then return () else do
1587
1588    -- and run it!
1589    exit_code <- system cmd  `catchAllIO`
1590                    (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
1591
1592    if exit_code /= ExitSuccess
1593         then throwDyn (PhaseFailed phase_name exit_code)
1594         else do on verb (putStr "\n")
1595                 return ()
1596
1597 -----------------------------------------------------------------------------
1598 -- Flags
1599
1600 data OptKind
1601         = NoArg (IO ())                 -- flag with no argument
1602         | HasArg (String -> IO ())      -- flag has an argument (maybe prefix)
1603         | SepArg (String -> IO ())      -- flag has a separate argument
1604         | Prefix (String -> IO ())      -- flag is a prefix only
1605         | OptPrefix (String -> IO ())   -- flag may be a prefix
1606         | AnySuffix (String -> IO ())   -- flag is a prefix, pass whole arg to fn
1607         | PassFlag  (String -> IO ())   -- flag with no arg, pass flag to fn
1608
1609 -- note that ordering is important in the following list: any flag which
1610 -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
1611 -- flags further down the list with the same prefix.
1612
1613 opts =
1614   [  ------- help -------------------------------------------------------
1615      ( "?"              , NoArg long_usage)
1616   ,  ( "-help"          , NoArg long_usage)
1617
1618
1619       ------- version ----------------------------------------------------
1620   ,  ( "-version"        , NoArg (do hPutStrLn stderr (cProjectName
1621                                       ++ ", version " ++ version_str)
1622                                      exitWith ExitSuccess))
1623   ,  ( "-numeric-version", NoArg (do hPutStrLn stderr version_str
1624                                      exitWith ExitSuccess))
1625
1626       ------- verbosity ----------------------------------------------------
1627   ,  ( "v"              , NoArg (writeIORef verbose True) )
1628   ,  ( "n"              , NoArg (writeIORef dry_run True) )
1629
1630         ------- recompilation checker --------------------------------------
1631   ,  ( "recomp"         , NoArg (writeIORef recomp True) )
1632   ,  ( "no-recomp"      , NoArg (writeIORef recomp False) )
1633
1634         ------- ways --------------------------------------------------------
1635   ,  ( "prof"           , NoArg (addNoDups ways WayProf) )
1636   ,  ( "unreg"          , NoArg (addNoDups ways WayUnreg) )
1637   ,  ( "ticky"          , NoArg (addNoDups ways WayTicky) )
1638   ,  ( "parallel"       , NoArg (addNoDups ways WayPar) )
1639   ,  ( "gransim"        , NoArg (addNoDups ways WayGran) )
1640   ,  ( "smp"            , NoArg (addNoDups ways WaySMP) )
1641   ,  ( "debug"          , NoArg (addNoDups ways WayDebug) )
1642         -- ToDo: user ways
1643
1644         ------- Interface files ---------------------------------------------
1645   ,  ( "hi"             , NoArg (writeIORef produceHi True) )
1646   ,  ( "nohi"           , NoArg (writeIORef produceHi False) )
1647   ,  ( "hi-diffs"       , NoArg (writeIORef hi_diffs  NormalHiDiffs) )
1648   ,  ( "no-hi-diffs"    , NoArg (writeIORef hi_diffs  NoHiDiffs) )
1649   ,  ( "hi-diffs-with-usages" , NoArg (writeIORef hi_diffs UsageHiDiffs) )
1650   ,  ( "keep-hi-diffs"  , NoArg (writeIORef keep_hi_diffs True) )
1651         --"hi-with-*"    -> hiw <- readIORef hi_with  (ToDo)
1652
1653         --------- Profiling --------------------------------------------------
1654   ,  ( "auto-dicts"     , NoArg (add opt_C "-fauto-sccs-on-dicts") )
1655   ,  ( "auto-all"       , NoArg (add opt_C "-fauto-sccs-on-all-toplevs") )
1656   ,  ( "auto"           , NoArg (add opt_C "-fauto-sccs-on-exported-toplevs") )
1657   ,  ( "caf-all"        , NoArg (add opt_C "-fauto-sccs-on-individual-cafs") )
1658          -- "ignore-sccs"  doesn't work  (ToDo)
1659
1660         ------- Miscellaneous -----------------------------------------------
1661   ,  ( "cpp"            , NoArg (writeIORef cpp_flag True) )
1662   ,  ( "#include"       , HasArg (add cmdline_hc_includes) )
1663   ,  ( "no-link-chk"    , NoArg (return ()) ) -- ignored for backwards compat
1664
1665         ------- Output Redirection ------------------------------------------
1666   ,  ( "odir"           , HasArg (writeIORef output_dir  . Just) )
1667   ,  ( "o"              , SepArg (writeIORef output_file . Just) )
1668   ,  ( "osuf"           , HasArg (writeIORef output_suf  . Just) )
1669   ,  ( "hisuf"          , HasArg (writeIORef hi_suf) )
1670   ,  ( "tmpdir"         , HasArg (writeIORef tmp_prefix  . (++ "/")) )
1671   ,  ( "ohi"            , HasArg (\s -> case s of
1672                                           "-" -> writeIORef hi_on_stdout True
1673                                           _   -> writeIORef output_hi (Just s)) )
1674         -- -odump?
1675
1676   ,  ( "keep-hc-file"   , AnySuffix (\_ -> writeIORef keep_hc_files True) )
1677   ,  ( "keep-s-file"    , AnySuffix (\_ -> writeIORef keep_s_files  True) )
1678   ,  ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef keep_raw_s_files  True) )
1679
1680   ,  ( "split-objs"     , NoArg (if can_split
1681                                     then do writeIORef split_object_files True
1682                                             writeIORef hsc_lang HscC
1683                                             add opt_C "-fglobalise-toplev-names"
1684                                             add opt_c "-DUSE_SPLIT_MARKERS"
1685                                     else hPutStrLn stderr
1686                                             "warning: don't know how to  split \
1687                                             \object files on this architecture"
1688                                 ) )
1689
1690         ------- Include/Import Paths ----------------------------------------
1691   ,  ( "i"              , OptPrefix augment_import_paths )
1692   ,  ( "I"              , Prefix augment_include_paths )
1693
1694         ------- Libraries ---------------------------------------------------
1695   ,  ( "L"              , Prefix augment_library_paths )
1696   ,  ( "l"              , Prefix (add cmdline_libraries) )
1697
1698         ------- Packages ----------------------------------------------------
1699   ,  ( "package-name"   , HasArg (\s -> add opt_C ("-inpackage="++s)) )
1700
1701   ,  ( "package"        , HasArg (addPackage) )
1702   ,  ( "syslib"         , HasArg (addPackage) ) -- for compatibility w/ old vsns
1703
1704         ------- Specific phases  --------------------------------------------
1705   ,  ( "pgmdep"         , HasArg (writeIORef pgm_dep) )
1706   ,  ( "pgmL"           , HasArg (writeIORef pgm_L) )
1707   ,  ( "pgmP"           , HasArg (writeIORef pgm_P) )
1708   ,  ( "pgmC"           , HasArg (writeIORef pgm_C) )
1709   ,  ( "pgmc"           , HasArg (writeIORef pgm_c) )
1710   ,  ( "pgmm"           , HasArg (writeIORef pgm_m) )
1711   ,  ( "pgms"           , HasArg (writeIORef pgm_s) )
1712   ,  ( "pgma"           , HasArg (writeIORef pgm_a) )
1713   ,  ( "pgml"           , HasArg (writeIORef pgm_l) )
1714
1715   ,  ( "optdep"         , HasArg (add opt_dep) )
1716   ,  ( "optL"           , HasArg (add opt_L) )
1717   ,  ( "optP"           , HasArg (add opt_P) )
1718   ,  ( "optCrts"        , HasArg (add opt_Crts) )
1719   ,  ( "optC"           , HasArg (add opt_C) )
1720   ,  ( "optc"           , HasArg (add opt_c) )
1721   ,  ( "optm"           , HasArg (add opt_m) )
1722   ,  ( "opta"           , HasArg (add opt_a) )
1723   ,  ( "optl"           , HasArg (add opt_l) )
1724   ,  ( "optdll"         , HasArg (add opt_dll) )
1725
1726         ------ HsCpp opts ---------------------------------------------------
1727   ,  ( "D"              , Prefix (\s -> add opt_P ("-D'"++s++"'") ) )
1728   ,  ( "U"              , Prefix (\s -> add opt_P ("-U'"++s++"'") ) )
1729
1730         ------ Warning opts -------------------------------------------------
1731   ,  ( "W"              , NoArg (writeIORef warning_opt W_))
1732   ,  ( "Wall"           , NoArg (writeIORef warning_opt W_all))
1733   ,  ( "Wnot"           , NoArg (writeIORef warning_opt W_not))
1734   ,  ( "w"              , NoArg (writeIORef warning_opt W_not))
1735
1736         ----- Linker --------------------------------------------------------
1737   ,  ( "static"         , NoArg (writeIORef static True) )
1738
1739         ------ Compiler RTS options -----------------------------------------
1740   ,  ( "H"                 , HasArg (sizeOpt specific_heap_size) )
1741   ,  ( "K"                 , HasArg (sizeOpt specific_stack_size) )
1742   ,  ( "Rscale-sizes"      , HasArg (floatOpt scale_sizes_by) )
1743   ,  ( "Rghc-timing"       , NoArg (writeIORef collect_ghc_timing True) )
1744
1745         ------ Debugging ----------------------------------------------------
1746   ,  ( "dstg-stats"        , NoArg (writeIORef opt_StgStats True) )
1747
1748   ,  ( "dno-"              , Prefix (\s -> add anti_opt_C ("-d"++s)) )
1749   ,  ( "d"                 , AnySuffix (add opt_C) )
1750
1751         ------ Machine dependant (-m<blah>) stuff ---------------------------
1752
1753   ,  ( "monly-2-regs",          NoArg (writeIORef stolen_x86_regs 2) )
1754   ,  ( "monly-3-regs",          NoArg (writeIORef stolen_x86_regs 3) )
1755   ,  ( "monly-4-regs",          NoArg (writeIORef stolen_x86_regs 4) )
1756
1757         ------ Compiler flags -----------------------------------------------
1758   ,  ( "O2-for-C"          , NoArg (writeIORef opt_minus_o2_for_C True) )
1759   ,  ( "O"                 , OptPrefix (setOptLevel) )
1760
1761   ,  ( "fglasgow-exts-no-lang", NoArg ( do add opt_C "-fglasgow-exts") )
1762
1763   ,  ( "fglasgow-exts"     , NoArg (do add opt_C "-fglasgow-exts"
1764                                        addPackage "lang"))
1765
1766   ,  ( "fasm"              , OptPrefix (\_ -> writeIORef hsc_lang HscAsm) )
1767
1768   ,  ( "fvia-C"            , NoArg (writeIORef hsc_lang HscC) )
1769
1770   ,  ( "fno-asm-mangling"  , NoArg (writeIORef do_asm_mangling False) )
1771
1772   ,  ( "fmax-simplifier-iterations",
1773                 Prefix (writeIORef opt_MaxSimplifierIterations . read) )
1774
1775   ,  ( "fusagesp",              NoArg (do writeIORef opt_UsageSPInf True
1776                                           add opt_C "-fusagesp-on") )
1777
1778         -- flags that are "active negatives"
1779   ,  ( "fno-implicit-prelude"   , PassFlag (add opt_C) )
1780   ,  ( "fno-prune-tydecls"      , PassFlag (add opt_C) )
1781   ,  ( "fno-prune-instdecls"    , PassFlag (add opt_C) )
1782   ,  ( "fno-pre-inlining"       , PassFlag (add opt_C) )
1783
1784         -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
1785   ,  ( "fno-",                  Prefix (\s -> add anti_opt_C ("-f"++s)) )
1786
1787         -- Pass all remaining "-f<blah>" options to hsc
1788   ,  ( "f",                     AnySuffix (add opt_C) )
1789   ]
1790
1791 -----------------------------------------------------------------------------
1792 -- Process command-line
1793
1794 processArgs :: [String] -> [String] -> IO [String]  -- returns spare args
1795 processArgs [] spare = return (reverse spare)
1796 processArgs args@(('-':_):_) spare = do
1797   args' <- processOneArg args
1798   processArgs args' spare
1799 processArgs (arg:args) spare =
1800   processArgs args (arg:spare)
1801
1802 processOneArg :: [String] -> IO [String]
1803 processOneArg (('-':arg):args) = do
1804   let (rest,action) = findArg arg
1805       dash_arg = '-':arg
1806   case action of
1807
1808         NoArg  io ->
1809                 if rest == ""
1810                         then io >> return args
1811                         else throwDyn (UnknownFlag dash_arg)
1812
1813         HasArg fio ->
1814                 if rest /= ""
1815                         then fio rest >> return args
1816                         else case args of
1817                                 [] -> throwDyn (UnknownFlag dash_arg)
1818                                 (arg1:args1) -> fio arg1 >> return args1
1819
1820         SepArg fio ->
1821                 case args of
1822                         [] -> throwDyn (UnknownFlag dash_arg)
1823                         (arg1:args1) -> fio arg1 >> return args1
1824
1825         Prefix fio ->
1826                 if rest /= ""
1827                         then fio rest >> return args
1828                         else throwDyn (UnknownFlag dash_arg)
1829
1830         OptPrefix fio -> fio rest >> return args
1831
1832         AnySuffix fio -> fio ('-':arg) >> return args
1833
1834         PassFlag fio  ->
1835                 if rest /= ""
1836                         then throwDyn (UnknownFlag dash_arg)
1837                         else fio ('-':arg) >> return args
1838
1839 findArg :: String -> (String,OptKind)
1840 findArg arg
1841   = case [ (remove_spaces rest, k) | (pat,k) <- opts,
1842                                      Just rest <- [my_prefix_match pat arg],
1843                                      is_prefix k || null rest ] of
1844         [] -> throwDyn (UnknownFlag ('-':arg))
1845         (one:_) -> one
1846
1847 is_prefix (NoArg _) = False
1848 is_prefix (SepArg _) = False
1849 is_prefix (PassFlag _) = False
1850 is_prefix _ = True
1851
1852 -----------------------------------------------------------------------------
1853 -- convert sizes like "3.5M" into integers
1854
1855 sizeOpt :: IORef Integer -> String -> IO ()
1856 sizeOpt ref str
1857   | c == ""              = writeSizeOpt ref (truncate n)
1858   | c == "K" || c == "k" = writeSizeOpt ref (truncate (n * 1000))
1859   | c == "M" || c == "m" = writeSizeOpt ref (truncate (n * 1000 * 1000))
1860   | c == "G" || c == "g" = writeSizeOpt ref (truncate (n * 1000 * 1000 * 1000))
1861   | otherwise            = throwDyn (UnknownFlag str)
1862   where (m, c) = span pred str
1863         n      = read m  :: Double
1864         pred c = isDigit c || c == '.'
1865
1866 writeSizeOpt :: IORef Integer -> Integer -> IO ()
1867 writeSizeOpt ref new = do
1868   current <- readIORef ref
1869   if (new > current)
1870         then writeIORef ref new
1871         else return ()
1872
1873 floatOpt :: IORef Double -> String -> IO ()
1874 floatOpt ref str
1875   = writeIORef ref (read str :: Double)
1876
1877 -----------------------------------------------------------------------------
1878 -- Finding files in the installation
1879
1880 GLOBAL_VAR(topDir, clibdir, String)
1881
1882         -- grab the last -B option on the command line, and
1883         -- set topDir to its value.
1884 setTopDir :: [String] -> IO [String]
1885 setTopDir args = do
1886   let (minusbs, others) = partition (prefixMatch "-B") args
1887   (case minusbs of
1888     []   -> writeIORef topDir clibdir
1889     some -> writeIORef topDir (drop 2 (last some)))
1890   return others
1891
1892 findFile name alt_path = unsafePerformIO (do
1893   top_dir <- readIORef topDir
1894   let installed_file = top_dir ++ '/':name
1895   let inplace_file   = top_dir ++ '/':cCURRENT_DIR ++ '/':alt_path
1896   b <- fileExist inplace_file
1897   if b  then return inplace_file
1898         else return installed_file
1899  )
1900
1901 -----------------------------------------------------------------------------
1902 -- Utils
1903
1904 my_partition :: (a -> Maybe b) -> [a] -> ([b],[a])
1905 my_partition p [] = ([],[])
1906 my_partition p (a:as)
1907   = let (bs,cs) = my_partition p as in
1908     case p a of
1909         Nothing -> (bs,a:cs)
1910         Just b  -> (b:bs,cs)
1911
1912 my_prefix_match :: String -> String -> Maybe String
1913 my_prefix_match [] rest = Just rest
1914 my_prefix_match (p:pat) [] = Nothing
1915 my_prefix_match (p:pat) (r:rest)
1916   | p == r    = my_prefix_match pat rest
1917   | otherwise = Nothing
1918
1919 prefixMatch :: Eq a => [a] -> [a] -> Bool
1920 prefixMatch [] str = True
1921 prefixMatch pat [] = False
1922 prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
1923                           | otherwise = False
1924
1925 postfixMatch :: String -> String -> Bool
1926 postfixMatch pat str = prefixMatch (reverse pat) (reverse str)
1927
1928 later = flip finally
1929
1930 on b io = if b then io >> return (error "on") else return (error "on")
1931
1932 my_catch = flip catchAllIO
1933 my_catchDyn = flip catchDyn
1934
1935 global :: a -> IORef a
1936 global a = unsafePerformIO (newIORef a)
1937
1938 split_filename :: String -> (String,String)
1939 split_filename f = (reverse rev_basename, reverse rev_ext)
1940   where (rev_ext, '.':rev_basename) = span ('.' /=) (reverse f)
1941
1942 split :: Char -> String -> [String]
1943 split c s = case rest of
1944                 []     -> [chunk]
1945                 _:rest -> chunk : split c rest
1946   where (chunk, rest) = break (==c) s
1947
1948 add :: IORef [a] -> a -> IO ()
1949 add var x = do
1950   xs <- readIORef var
1951   writeIORef var (x:xs)
1952
1953 addNoDups :: Eq a => IORef [a] -> a -> IO ()
1954 addNoDups var x = do
1955   xs <- readIORef var
1956   if x `elem` xs then return () else writeIORef var (x:xs)
1957
1958 remove_suffix :: String -> Char -> String
1959 remove_suffix s c
1960   | null pre  = reverse suf
1961   | otherwise = reverse pre
1962   where (suf,pre) = break (==c) (reverse s)
1963
1964 drop_longest_prefix :: String -> Char -> String
1965 drop_longest_prefix s c = reverse suf
1966   where (suf,pre) = break (==c) (reverse s)
1967
1968 take_longest_prefix :: String -> Char -> String
1969 take_longest_prefix s c = reverse pre
1970   where (suf,pre) = break (==c) (reverse s)
1971
1972 newsuf :: String -> String -> String
1973 newsuf suf s = remove_suffix s '.' ++ suf
1974
1975 -- getdir strips the filename off the input string, returning the directory.
1976 getdir :: String -> String
1977 getdir s = if null dir then "." else init dir
1978   where dir = take_longest_prefix s '/'
1979
1980 newdir :: String -> String -> String
1981 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
1982
1983 remove_spaces :: String -> String
1984 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace