ghc/driver/Main.hs

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