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