ghc/compiler/main/Main.hs

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