ghc/driver/Main.hs

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