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           (unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
1206
1207 --    $to_do  = "echo '#line 1 \"$in_lit2pgm\"' > $lit2pgm_hscpp && " if ($Cpp_flag_set);
1208
1209 -------------------------------------------------------------------------------
1210 -- HsCpp phase
1211
1212 run_phase Cpp basename input_fn output_fn
1213   = do src_opts <- getOptionsFromSource input_fn
1214        processArgs src_opts []
1215
1216        do_cpp <- readIORef cpp_flag
1217        if do_cpp
1218           then do
1219             cpp <- readIORef pgm_P
1220             hscpp_opts <- getOpts opt_P
1221             hs_src_cpp_opts <- readIORef hs_source_cpp_opts
1222
1223             cmdline_include_paths <- readIORef include_paths
1224             let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
1225
1226             verb <- is_verbose
1227             run_something "C pre-processor"
1228                 (unwords
1229                    (["echo \'{-# LINE 1 \"hello.hs\" -}\'", ">", output_fn, "&&",
1230                      cpp, verb]
1231                     ++ cmdline_include_flags
1232                     ++ hs_src_cpp_opts
1233                     ++ hscpp_opts
1234                     ++ [ input_fn, ">>", output_fn ]
1235                    ))
1236           else do
1237             run_something "Inefective C pre-processor"
1238                    ("echo '{-# LINE 1 \""  ++ input_fn ++ "\" -}' > "
1239                     ++ output_fn ++ " && cat " ++ input_fn
1240                     ++ " >> " ++ output_fn)
1241
1242 -----------------------------------------------------------------------------
1243 -- Hsc phase
1244
1245 run_phase Hsc   basename input_fn output_fn
1246   = do  hsc <- readIORef pgm_C
1247
1248   -- we add the current directory (i.e. the directory in which
1249   -- the .hs files resides) to the import path, since this is
1250   -- what gcc does, and it's probably what you want.
1251         let (root,dir) = break (=='/') (reverse basename)
1252             current_dir = if null dir then "." else reverse dir
1253
1254         paths <- readIORef include_paths
1255         writeIORef include_paths (current_dir : paths)
1256
1257   -- build the hsc command line
1258         hsc_opts <- build_hsc_opts
1259
1260         doing_hi <- readIORef produceHi
1261         tmp_hi_file <- if doing_hi
1262                           then do fn <- newTempName "hi"
1263                                   add files_to_clean fn
1264                                   return fn
1265                           else return ""
1266
1267         let hi_flag = if doing_hi then "-hifile=" ++ tmp_hi_file
1268                                   else ""
1269
1270   -- deal with -Rghc-timing
1271         timing <- readIORef collect_ghc_timing
1272         stat_file <- newTempName "stat"
1273         add files_to_clean stat_file
1274         let stat_opts | timing    = [ "+RTS", "-S"++stat_file, "-RTS" ]
1275                       | otherwise = []
1276
1277   -- tmp files for foreign export stub code
1278         tmp_stub_h <- newTempName "stub_h"
1279         tmp_stub_c <- newTempName "stub_c"
1280         add files_to_clean tmp_stub_h
1281         add files_to_clean tmp_stub_c
1282
1283         run_something "Haskell Compiler"
1284                  (unwords (hsc : input_fn : (
1285                     hsc_opts
1286                     ++ [ hi_flag, " -ofile="++output_fn ]
1287                     ++ [ "-F="++tmp_stub_c, "-FH="++tmp_stub_h ]
1288                     ++ stat_opts
1289                  )))
1290
1291   -- Copy the .hi file into the current dir if it changed
1292         on doing_hi
1293                   (do ohi <- readIORef output_hi
1294                       hisuf <- readIORef hi_suf
1295                       let hi_target = case ohi of
1296                                         Nothing -> basename ++ '.':hisuf
1297                                         Just fn -> fn
1298                       new_hi_file <- fileExist tmp_hi_file
1299                       on new_hi_file
1300                              (run_something "Copy hi file"
1301                                 (unwords ["mv", tmp_hi_file, hi_target]))
1302                   )
1303
1304   -- Generate -Rghc-timing info
1305         on (timing) (
1306             run_something "Generate timing stats"
1307                 (findFile "ghc-stats" _GHC_STATS ++ ' ':stat_file)
1308          )
1309
1310   -- Deal with stubs
1311         let stub_h = basename ++ "_stub.h"
1312         let stub_c = basename ++ "_stub.c"
1313
1314                 -- copy .h_stub file into current dir if present
1315         b <- fileExist tmp_stub_h
1316         on b (do
1317                 run_something "Copy stub .h file"
1318                                 ("cp " ++ tmp_stub_h ++ ' ':stub_h)
1319
1320                         -- #include <..._stub.h> in .hc file
1321                 add cmdline_hc_includes tmp_stub_h      -- hack
1322
1323                         -- copy the _stub.c file into the current dir
1324                 run_something "Copy stub .c file"
1325                     (unwords [
1326                         "rm -f", stub_c, "&&",
1327                         "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
1328                         "cat", tmp_stub_c, ">> ", stub_c
1329                         ])
1330
1331                         -- compile the _stub.c file w/ gcc
1332                 run_pipeline As False (basename++"_stub") (Cc, stub_c)
1333                 add ld_inputs (basename++"_stub.o")
1334          )
1335
1336 -----------------------------------------------------------------------------
1337 -- Cc phase
1338
1339 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
1340 -- way too many hacks, and I can't say I've ever used it anyway.
1341
1342 run_phase cc_phase basename input_fn output_fn
1343    | cc_phase == Cc || cc_phase == HCc
1344    = do cc <- readIORef pgm_c
1345         cc_opts <- getOpts opt_c
1346         cmdline_include_dirs <- readIORef include_paths
1347        -- ToDo: $c_flags .= " -mno-cygwin" if ( $TargetPlatform =~ /-mingw32$/ );
1348
1349         let hcc = cc_phase == HCc
1350
1351                 -- add package include paths even if we're just compiling
1352                 -- .c files; this is the Value Add(TM) that using
1353                 -- ghc instead of gcc gives you :)
1354         pkg_include_dirs <- getPackageIncludePath
1355         let include_paths = map (\p -> "-I"++p) (cmdline_include_dirs
1356                                                         ++ pkg_include_dirs)
1357
1358         c_includes <- getPackageCIncludes
1359         cmdline_includes <- readIORef cmdline_hc_includes -- -#include options
1360
1361         let cc_injects | hcc = unlines (map mk_include
1362                                         (c_includes ++ reverse cmdline_includes))
1363                        | otherwise = ""
1364             mk_include h_file =
1365                 case h_file of
1366                    '"':_{-"-} -> "#include "++h_file
1367                    '<':_      -> "#include "++h_file
1368                    _          -> "#include \""++h_file++"\""
1369
1370         cc_help <- newTempName "c"
1371         add files_to_clean cc_help
1372         h <- openFile cc_help WriteMode
1373         hPutStr h cc_injects
1374         hPutStrLn h ("#include \"" ++ input_fn ++ "\"\n")
1375         hClose h
1376
1377         ccout <- newTempName "ccout"
1378         add files_to_clean ccout
1379
1380         mangle <- readIORef do_asm_mangling
1381         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
1382
1383         verb <- is_verbose
1384
1385         o2 <- readIORef opt_minus_o2_for_C
1386         let opt_flag | o2        = "-O2"
1387                      | otherwise = "-O"
1388
1389         run_something "C Compiler"
1390          (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
1391                    ++ md_c_flags
1392                    ++ (if cc_phase == HCc && mangle
1393                          then md_regd_c_flags
1394                          else [])
1395                    ++ [ verb, "-S", "-Wimplicit", opt_flag ]
1396                    ++ cc_opts
1397                    ++ include_paths
1398 --                 ++ [">", ccout]
1399                    ))
1400
1401         -- ToDo: postprocess the output from gcc
1402
1403 -----------------------------------------------------------------------------
1404 -- Mangle phase
1405
1406 run_phase Mangle basename input_fn output_fn
1407   = do mangler <- readIORef pgm_m
1408        mangler_opts <- getOpts opt_m
1409        machdep_opts <-
1410          if (prefixMatch "i386" _TARGETPLATFORM)
1411             then do n_regs <- readIORef stolen_x86_regs
1412                     return [ show n_regs ]
1413             else return []
1414        run_something "Assembly Mangler"
1415         (unwords (mangler :
1416                      mangler_opts
1417                   ++ [ input_fn, output_fn ]
1418                   ++ machdep_opts
1419                 ))
1420
1421 -----------------------------------------------------------------------------
1422 -- Splitting phase
1423
1424 run_phase SplitMangle basename input_fn outputfn
1425   = do  splitter <- readIORef pgm_s
1426
1427         -- this is the prefix used for the split .s files
1428         tmp_pfx <- readIORef tmp_prefix
1429         x <- getProcessID
1430         let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
1431         writeIORef split_prefix split_s_prefix
1432         add files_to_clean (split_s_prefix ++ "__*") -- d:-)
1433
1434         -- allocate a tmp file to put the no. of split .s files in (sigh)
1435         n_files <- newTempName "n_files"
1436         add files_to_clean n_files
1437
1438         run_something "Split Assembly File"
1439          (unwords [ splitter
1440                   , input_fn
1441                   , split_s_prefix
1442                   , n_files ]
1443          )
1444
1445         -- save the number of split files for future references
1446         s <- readFile n_files
1447         let n = read s :: Int
1448         writeIORef n_split_files n
1449
1450 -----------------------------------------------------------------------------
1451 -- As phase
1452
1453 run_phase As basename input_fn output_fn
1454   = do  split <- readIORef split_object_files
1455         as <- readIORef pgm_a
1456         as_opts <- getOpts opt_a
1457
1458         if not split then do
1459             cmdline_include_paths <- readIORef include_paths
1460             let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
1461             run_something "Assembler"
1462              (unwords (as : as_opts
1463                        ++ cmdline_include_flags
1464                        ++ [ "-c", input_fn, "-o",  output_fn ]
1465                     ))
1466
1467          else do
1468             odir_opt <- readIORef output_dir
1469             let odir | Just s <- odir_opt = s
1470                      | otherwise          = basename
1471
1472             split_s_prefix <- readIORef split_prefix
1473             n <- readIORef n_split_files
1474
1475             odir <- readIORef output_dir
1476             let real_odir = case odir of
1477                                 Nothing -> basename
1478                                 Just d  -> d
1479
1480             let assemble_file n = do
1481                     let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
1482                     let output_o = newdir real_odir
1483                                         (basename ++ "__" ++ show n ++ ".o")
1484                     run_something "Assembler"
1485                             (unwords (as : as_opts
1486                                       ++ [ "-c", "-o ", output_o, input_s ]
1487                             ))
1488
1489             mapM_ assemble_file [1..n]
1490
1491 -----------------------------------------------------------------------------
1492 -- Linking
1493
1494 do_link :: [String] -> [String] -> IO ()
1495 do_link o_files unknown_srcs = do
1496     ln <- readIORef pgm_l
1497     verb <- is_verbose
1498     o_file <- readIORef output_file
1499     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1500
1501     pkg_lib_paths <- getPackageLibraryPath
1502     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1503
1504     lib_paths <- readIORef library_paths
1505     let lib_path_opts = map ("-L"++) lib_paths
1506
1507     pkg_libs <- getPackageLibraries
1508     let pkg_lib_opts = map ("-l"++) pkg_libs
1509
1510     libs <- readIORef cmdline_libraries
1511     let lib_opts = map ("-l"++) (reverse libs)
1512          -- reverse because they're added in reverse order from the cmd line
1513
1514     pkg_extra_ld_opts <- getPackageExtraLdOpts
1515
1516         -- probably _stub.o files
1517     extra_ld_inputs <- readIORef ld_inputs
1518
1519     run_something "Linker"
1520        (unwords
1521          ([ ln, verb, "-o", output_fn ]
1522              -- ToDo: -u <blah> options
1523          ++ o_files
1524          ++ unknown_srcs
1525          ++ extra_ld_inputs
1526          ++ lib_path_opts
1527          ++ lib_opts
1528          ++ pkg_lib_path_opts
1529          ++ pkg_lib_opts
1530          ++ pkg_extra_ld_opts
1531         )
1532        )
1533
1534 -----------------------------------------------------------------------------
1535 -- Running an external program
1536
1537 run_something phase_name cmd
1538  = do
1539    verb <- readIORef verbose
1540    if verb then do
1541         putStr phase_name
1542         putStrLn ":"
1543         putStrLn cmd
1544      else
1545         return ()
1546
1547    -- test for -n flag
1548    n <- readIORef dry_run
1549    if n then return () else do
1550
1551    -- and run it!
1552    exit_code <- system cmd  `catchAllIO`
1553                    (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
1554
1555    if exit_code /= ExitSuccess
1556         then throwDyn (PhaseFailed phase_name exit_code)
1557         else do on verb (putStr "\n")
1558                 return ()
1559
1560 -----------------------------------------------------------------------------
1561 -- Flags
1562
1563 data OptKind
1564         = NoArg (IO ())                 -- flag with no argument
1565         | HasArg (String -> IO ())      -- flag has an argument (maybe prefix)
1566         | SepArg (String -> IO ())      -- flag has a separate argument
1567         | Prefix (String -> IO ())      -- flag is a prefix only
1568         | OptPrefix (String -> IO ())   -- flag may be a prefix
1569         | AnySuffix (String -> IO ())   -- flag is a prefix, pass whole arg to fn
1570         | PassFlag  (String -> IO ())   -- flag with no arg, pass flag to fn
1571
1572 opts =
1573   [  ------- help -------------------------------------------------------
1574      ( "?"              , NoArg long_usage)
1575   ,  ( "-help"          , NoArg long_usage)
1576
1577
1578       ------- version ----------------------------------------------------
1579   ,  ( "-version"       , NoArg (do hPutStrLn stderr (_ProjectName
1580                                       ++ ", version " ++ _ProjectVersion
1581                                       ++ ", patchlevel " ++ _ProjectPatchLevel)
1582                                     exitWith ExitSuccess))
1583
1584       ------- verbosity ----------------------------------------------------
1585   ,  ( "v"              , NoArg (writeIORef verbose True) )
1586   ,  ( "n"              , NoArg (writeIORef dry_run True) )
1587
1588         ------- recompilation checker --------------------------------------
1589   ,  ( "recomp"         , NoArg (writeIORef recomp True) )
1590   ,  ( "no-recomp"      , NoArg (writeIORef recomp False) )
1591
1592         ------- ways --------------------------------------------------------
1593   ,  ( "prof"           , NoArg (add ways WayProf) )
1594   ,  ( "unreg"          , NoArg (add ways WayUnreg) )
1595   ,  ( "ticky"          , NoArg (add ways WayTicky) )
1596   ,  ( "parallel"       , NoArg (add ways WayPar) )
1597   ,  ( "gransim"        , NoArg (add ways WayGran) )
1598   ,  ( "smp"            , NoArg (add ways WaySMP) )
1599   ,  ( "debug"          , NoArg (add ways WayDebug) )
1600         -- ToDo: user ways
1601
1602         ------- Interface files ---------------------------------------------
1603   ,  ( "hi"             , NoArg (writeIORef produceHi True) )
1604   ,  ( "nohi"           , NoArg (writeIORef produceHi False) )
1605   ,  ( "hi-diffs"       , NoArg (writeIORef hi_diffs  NormalHiDiffs) )
1606   ,  ( "no-hi-diffs"    , NoArg (writeIORef hi_diffs  NoHiDiffs) )
1607   ,  ( "hi-diffs-with-usages" , NoArg (writeIORef hi_diffs UsageHiDiffs) )
1608   ,  ( "keep-hi-diffs"  , NoArg (writeIORef keep_hi_diffs True) )
1609         --"hi-with-*"    -> hiw <- readIORef hi_with  (ToDo)
1610
1611         --------- Profiling --------------------------------------------------
1612   ,  ( "auto-dicts"     , NoArg (add opt_C "-fauto-sccs-on-dicts") )
1613   ,  ( "auto-all"       , NoArg (add opt_C "-fauto-sccs-on-all-toplevs") )
1614   ,  ( "auto"           , NoArg (add opt_C "-fauto-sccs-on-exported-toplevs") )
1615   ,  ( "caf-all"        , NoArg (add opt_C "-fauto-sccs-on-individual-cafs") )
1616          -- "ignore-sccs"  doesn't work  (ToDo)
1617
1618         ------- Miscellaneous -----------------------------------------------
1619   ,  ( "cpp"            , NoArg (writeIORef cpp_flag True) )
1620   ,  ( "#include"       , SepArg (add cmdline_hc_includes) )
1621
1622         ------- Output Redirection ------------------------------------------
1623   ,  ( "odir"           , HasArg (writeIORef output_dir  . Just) )
1624   ,  ( "o"              , SepArg (writeIORef output_file . Just) )
1625   ,  ( "osuf"           , HasArg (writeIORef output_suf  . Just) )
1626   ,  ( "hisuf"          , HasArg (writeIORef hi_suf) )
1627   ,  ( "tmpdir"         , HasArg (writeIORef tmp_prefix  . (++ "/")) )
1628   ,  ( "ohi"            , HasArg (\s -> case s of
1629                                           "-" -> writeIORef hi_on_stdout True
1630                                           _   -> writeIORef output_hi (Just s)) )
1631         -- -odump?
1632
1633   ,  ( "keep-hc-file"   , AnySuffix (\_ -> writeIORef keep_hc_files True) )
1634   ,  ( "keep-s-file"    , AnySuffix (\_ -> writeIORef keep_s_files  True) )
1635   ,  ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef keep_raw_s_files  True) )
1636
1637   ,  ( "split-objs"     , NoArg (if can_split
1638                                     then do writeIORef split_object_files True
1639                                             writeIORef hsc_lang HscC
1640                                             add opt_C "-fglobalise-toplev-names"
1641                                             add opt_c "-DUSE_SPLIT_MARKERS"
1642                                     else hPutStrLn stderr
1643                                             "warning: don't know how to  split \
1644                                             \object files on this architecture"
1645                                 ) )
1646
1647         ------- Include/Import Paths ----------------------------------------
1648   ,  ( "i"              , OptPrefix augment_import_paths )
1649   ,  ( "I"              , Prefix augment_include_paths )
1650
1651         ------- Libraries ---------------------------------------------------
1652   ,  ( "L"              , Prefix augment_library_paths )
1653   ,  ( "l"              , Prefix (add cmdline_libraries) )
1654
1655         ------- Packages ----------------------------------------------------
1656   ,  ( "package-name"   , HasArg (\s -> add opt_C ("-inpackage="++s)) )
1657
1658   ,  ( "package"        , HasArg (addPackage) )
1659   ,  ( "syslib"         , HasArg (addPackage) ) -- for compatibility w/ old vsns
1660
1661         ------- Specific phases  --------------------------------------------
1662   ,  ( "pgmdep"         , HasArg (writeIORef pgm_dep) )
1663   ,  ( "pgmL"           , HasArg (writeIORef pgm_L) )
1664   ,  ( "pgmP"           , HasArg (writeIORef pgm_P) )
1665   ,  ( "pgmC"           , HasArg (writeIORef pgm_C) )
1666   ,  ( "pgmc"           , HasArg (writeIORef pgm_c) )
1667   ,  ( "pgmm"           , HasArg (writeIORef pgm_m) )
1668   ,  ( "pgms"           , HasArg (writeIORef pgm_s) )
1669   ,  ( "pgma"           , HasArg (writeIORef pgm_a) )
1670   ,  ( "pgml"           , HasArg (writeIORef pgm_l) )
1671
1672   ,  ( "optdep"         , HasArg (add opt_dep) )
1673   ,  ( "optL"           , HasArg (add opt_L) )
1674   ,  ( "optP"           , HasArg (add opt_P) )
1675   ,  ( "optC"           , HasArg (add opt_C) )
1676   ,  ( "optCrts"        , HasArg (add opt_Crts) )
1677   ,  ( "optc"           , HasArg (add opt_c) )
1678   ,  ( "optm"           , HasArg (add opt_m) )
1679   ,  ( "opta"           , HasArg (add opt_a) )
1680   ,  ( "optl"           , HasArg (add opt_l) )
1681   ,  ( "optdll"         , HasArg (add opt_dll) )
1682
1683         ------ HsCpp opts ---------------------------------------------------
1684   ,  ( "D"              , Prefix (\s -> add opt_P ("-D'"++s++"'") ) )
1685   ,  ( "U"              , Prefix (\s -> add opt_P ("-U'"++s++"'") ) )
1686
1687         ------ Warning opts -------------------------------------------------
1688   ,  ( "W"              , NoArg (writeIORef warning_opt W_))
1689   ,  ( "Wall"           , NoArg (writeIORef warning_opt W_all))
1690   ,  ( "Wnot"           , NoArg (writeIORef warning_opt W_not))
1691   ,  ( "w"              , NoArg (writeIORef warning_opt W_not))
1692
1693         ----- Linker --------------------------------------------------------
1694   ,  ( "static"         , NoArg (writeIORef static True) )
1695
1696         ------ Compiler RTS options -----------------------------------------
1697   ,  ( "H"                 , HasArg (sizeOpt specific_heap_size) )
1698   ,  ( "K"                 , HasArg (sizeOpt specific_stack_size) )
1699   ,  ( "Rscale-sizes"      , HasArg (floatOpt scale_sizes_by) )
1700   ,  ( "Rghc-timing"       , NoArg (writeIORef collect_ghc_timing True) )
1701
1702         ------ Debugging ----------------------------------------------------
1703   ,  ( "dstg-stats"        , NoArg (writeIORef opt_StgStats True) )
1704
1705   ,  ( "dno-"              , Prefix (\s -> add anti_opt_C ("-d"++s)) )
1706   ,  ( "d"                 , AnySuffix (add opt_C) )
1707
1708         ------ Machine dependant (-m<blah>) stuff ---------------------------
1709
1710   ,  ( "monly-2-regs",          NoArg (writeIORef stolen_x86_regs 2) )
1711   ,  ( "monly-3-regs",          NoArg (writeIORef stolen_x86_regs 3) )
1712   ,  ( "monly-4-regs",          NoArg (writeIORef stolen_x86_regs 4) )
1713
1714         ------ Compiler flags -----------------------------------------------
1715   ,  ( "O2-for-C"          , NoArg (writeIORef opt_minus_o2_for_C True) )
1716   ,  ( "O"                 , OptPrefix (setOptLevel) )
1717
1718   ,  ( "fglasgow-exts-no-lang", NoArg ( do add opt_C "-fglasgow-exts") )
1719
1720   ,  ( "fglasgow-exts"     , NoArg (do add opt_C "-fglasgow-exts"
1721                                        addPackage "lang"))
1722
1723   ,  ( "fasm"              , OptPrefix (\_ -> writeIORef hsc_lang HscAsm) )
1724
1725   ,  ( "fvia-C"            , NoArg (writeIORef hsc_lang HscC) )
1726
1727   ,  ( "fno-asm-mangling"  , NoArg (writeIORef do_asm_mangling True) )
1728
1729   ,  ( "fmax-simplifier-iterations",
1730                 Prefix (writeIORef opt_MaxSimplifierIterations . read) )
1731
1732   ,  ( "fusagesp",              NoArg (do writeIORef opt_UsageSPInf True
1733                                           add opt_C "-fusagesp-on") )
1734
1735         -- flags that are "active negatives"
1736   ,  ( "fno-implicit-prelude"   , PassFlag (add opt_C) )
1737   ,  ( "fno-prune-tydecls"      , PassFlag (add opt_C) )
1738   ,  ( "fno-prune-instdecls"    , PassFlag (add opt_C) )
1739   ,  ( "fno-pre-inlining"       , PassFlag (add opt_C) )
1740
1741         -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
1742   ,  ( "fno-",                  Prefix (\s -> add anti_opt_C ("-f"++s)) )
1743
1744         -- Pass all remaining "-f<blah>" options to hsc
1745   ,  ( "f",                     AnySuffix (add opt_C) )
1746   ]
1747
1748 -----------------------------------------------------------------------------
1749 -- Process command-line
1750
1751 processArgs :: [String] -> [String] -> IO [String]  -- returns spare args
1752 processArgs [] spare = return (reverse spare)
1753 processArgs args@(('-':_):_) spare = do
1754   args' <- processOneArg args
1755   processArgs args' spare
1756 processArgs (arg:args) spare =
1757   processArgs args (arg:spare)
1758
1759 processOneArg :: [String] -> IO [String]
1760 processOneArg (('-':arg):args) = do
1761   let (rest,action) = findArg arg
1762       dash_arg = '-':arg
1763   case action of
1764
1765         NoArg  io ->
1766                 if rest == ""
1767                         then io >> return args
1768                         else throwDyn (UnknownFlag dash_arg)
1769
1770         HasArg fio ->
1771                 if rest /= ""
1772                         then fio rest >> return args
1773                         else case args of
1774                                 [] -> throwDyn (UnknownFlag dash_arg)
1775                                 (arg1:args1) -> fio arg1 >> return args1
1776
1777         SepArg fio ->
1778                 case args of
1779                         [] -> throwDyn (UnknownFlag dash_arg)
1780                         (arg1:args1) -> fio arg1 >> return args1
1781
1782         Prefix fio ->
1783                 if rest /= ""
1784                         then fio rest >> return args
1785                         else throwDyn (UnknownFlag dash_arg)
1786
1787         OptPrefix fio -> fio rest >> return args
1788
1789         AnySuffix fio -> fio ('-':arg) >> return args
1790
1791         PassFlag fio  ->
1792                 if rest /= ""
1793                         then throwDyn (UnknownFlag dash_arg)
1794                         else fio ('-':arg) >> return args
1795
1796 findArg :: String -> (String,OptKind)
1797 findArg arg
1798   = case [ (rest,k) | (pat,k) <- opts,
1799                       Just rest <- [my_prefix_match pat arg],
1800                       is_prefix k || null rest ] of
1801         [] -> throwDyn (UnknownFlag ('-':arg))
1802         (one:_) -> one
1803
1804 is_prefix (NoArg _) = False
1805 is_prefix (SepArg _) = False
1806 is_prefix (PassFlag _) = False
1807 is_prefix _ = True
1808
1809 -----------------------------------------------------------------------------
1810 -- convert sizes like "3.5M" into integers
1811
1812 sizeOpt :: IORef Integer -> String -> IO ()
1813 sizeOpt ref str
1814   | c == ""              = writeSizeOpt ref (truncate n)
1815   | c == "K" || c == "k" = writeSizeOpt ref (truncate (n * 1000))
1816   | c == "M" || c == "m" = writeSizeOpt ref (truncate (n * 1000 * 1000))
1817   | c == "G" || c == "g" = writeSizeOpt ref (truncate (n * 1000 * 1000 * 1000))
1818   | otherwise            = throwDyn (UnknownFlag str)
1819   where (m, c) = span pred str
1820         n      = read m  :: Double
1821         pred c = isDigit c || c == '.'
1822
1823 writeSizeOpt :: IORef Integer -> Integer -> IO ()
1824 writeSizeOpt ref new = do
1825   current <- readIORef ref
1826   if (new > current)
1827         then writeIORef ref new
1828         else return ()
1829
1830 floatOpt :: IORef Double -> String -> IO ()
1831 floatOpt ref str
1832   = writeIORef ref (read str :: Double)
1833
1834 -----------------------------------------------------------------------------
1835 -- Finding files in the installation
1836
1837 GLOBAL_VAR(topDir, _libdir, String)
1838
1839         -- grab the last -B option on the command line, and
1840         -- set topDir to its value.
1841 setTopDir :: [String] -> IO [String]
1842 setTopDir args = do
1843   let (minusbs, others) = partition (prefixMatch "-B") args
1844   (case minusbs of
1845     []   -> writeIORef topDir _libdir
1846     some -> writeIORef topDir (drop 2 (last some)))
1847   return others
1848
1849 findFile name alt_path = unsafePerformIO (do
1850   top_dir <- readIORef topDir
1851   let installed_file = top_dir ++ '/':name
1852   let inplace_file   = top_dir ++ '/':_CURRENT_DIR ++ '/':alt_path
1853   b <- fileExist inplace_file
1854   if b  then return inplace_file
1855         else return installed_file
1856  )
1857
1858 -----------------------------------------------------------------------------
1859 -- Utils
1860
1861 my_partition :: (a -> Maybe b) -> [a] -> ([b],[a])
1862 my_partition p [] = ([],[])
1863 my_partition p (a:as)
1864   = let (bs,cs) = my_partition p as in
1865     case p a of
1866         Nothing -> (bs,a:cs)
1867         Just b  -> (b:bs,cs)
1868
1869 my_prefix_match :: String -> String -> Maybe String
1870 my_prefix_match [] rest = Just rest
1871 my_prefix_match (p:pat) [] = Nothing
1872 my_prefix_match (p:pat) (r:rest)
1873   | p == r    = my_prefix_match pat rest
1874   | otherwise = Nothing
1875
1876 prefixMatch :: Eq a => [a] -> [a] -> Bool
1877 prefixMatch [] str = True
1878 prefixMatch pat [] = False
1879 prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
1880                           | otherwise = False
1881
1882 postfixMatch :: String -> String -> Bool
1883 postfixMatch pat str = prefixMatch (reverse pat) (reverse str)
1884
1885 later = flip finally
1886
1887 on b io = if b then io >> return (error "on") else return (error "on")
1888
1889 my_catch = flip catchAllIO
1890 my_catchDyn = flip catchDyn
1891
1892 global :: a -> IORef a
1893 global a = unsafePerformIO (newIORef a)
1894
1895 split_filename :: String -> (String,String)
1896 split_filename f = (reverse rev_basename, reverse rev_ext)
1897   where (rev_ext, '.':rev_basename) = span ('.' /=) (reverse f)
1898
1899 split :: Char -> String -> [String]
1900 split c s = case rest of
1901                 []     -> [chunk]
1902                 _:rest -> chunk : split c rest
1903   where (chunk, rest) = break (==c) s
1904
1905 add :: IORef [a] -> a -> IO ()
1906 add var x = do
1907   xs <- readIORef var
1908   writeIORef var (x:xs)
1909
1910 remove_suffix :: String -> Char -> String
1911 remove_suffix s c
1912   | null pre  = reverse suf
1913   | otherwise = reverse pre
1914   where (suf,pre) = break (==c) (reverse s)
1915
1916 drop_longest_prefix :: String -> Char -> String
1917 drop_longest_prefix s c = reverse suf
1918   where (suf,pre) = break (==c) (reverse s)
1919
1920 take_longest_prefix :: String -> Char -> String
1921 take_longest_prefix s c = reverse pre
1922   where (suf,pre) = break (==c) (reverse s)
1923
1924 newsuf :: String -> String -> String
1925 newsuf suf s = remove_suffix s '.' ++ suf
1926
1927 newdir :: String -> String -> String
1928 newdir dir s = dir ++ '/':drop_longest_prefix s '/'