ghc/driver/Main.hs

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