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