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