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