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