ghc/driver/Main.hs

   1 {-# OPTIONS -W #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: Main.hs,v 1.45 2000/08/02 15:27:25 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
 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 augment_import_paths :: String -> IO ()
 609 augment_import_paths "" = writeIORef import_paths []
 610 augment_import_paths path
 611   = do paths <- readIORef import_paths
 612        writeIORef import_paths (paths ++ dirs)
 613   where dirs = split split_marker path
 614
 615 augment_include_paths :: String -> IO ()
 616 augment_include_paths path
 617   = do paths <- readIORef include_paths
 618        writeIORef include_paths (paths ++ split split_marker path)
 619
 620 augment_library_paths :: String -> IO ()
 621 augment_library_paths path
 622   = do paths <- readIORef library_paths
 623        writeIORef library_paths (paths ++ split split_marker path)
 624
 625 -----------------------------------------------------------------------------
 626 -- Packages
 627
 628 GLOBAL_VAR(package_config, (findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")), String)
 629
 630 listPackages :: IO ()
 631 listPackages = do
 632   details <- readIORef package_details
 633   hPutStr stdout (listPkgs details)
 634   hPutChar stdout '\n'
 635   exitWith ExitSuccess
 636
 637 newPackage :: IO ()
 638 newPackage = do
 639   checkConfigAccess
 640   details <- readIORef package_details
 641   hPutStr stdout "Reading package info from stdin... "
 642   stuff <- getContents
 643   let new_pkg = read stuff :: (String,Package)
 644   catchAll new_pkg
 645         (\_ -> throwDyn (OtherError "parse error in package info"))
 646   hPutStrLn stdout "done."
 647   if (fst new_pkg `elem` map fst details)
 648         then throwDyn (OtherError ("package `" ++ fst new_pkg ++
 649                                         "' already installed"))
 650         else do
 651   conf_file <- readIORef package_config
 652   savePackageConfig conf_file
 653   maybeRestoreOldConfig conf_file $ do
 654   writeNewConfig conf_file ( ++ [new_pkg])
 655   exitWith ExitSuccess
 656
 657 deletePackage :: String -> IO ()
 658 deletePackage pkg = do
 659   checkConfigAccess
 660   details <- readIORef package_details
 661   if (pkg `notElem` map fst details)
 662         then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
 663         else do
 664   conf_file <- readIORef package_config
 665   savePackageConfig conf_file
 666   maybeRestoreOldConfig conf_file $ do
 667   writeNewConfig conf_file (filter ((/= pkg) . fst))
 668   exitWith ExitSuccess
 669
 670 checkConfigAccess :: IO ()
 671 checkConfigAccess = do
 672   conf_file <- readIORef package_config
 673   access <- getPermissions conf_file
 674   unless (writable access)
 675         (throwDyn (OtherError "you don't have permission to modify the package configuration file"))
 676
 677 maybeRestoreOldConfig :: String -> IO () -> IO ()
 678 maybeRestoreOldConfig conf_file io
 679   = catchAllIO io (\e -> do
 680         hPutStr stdout "\nWARNING: an error was encountered while the new \n\
 681                        \configuration was being written.  Attempting to \n\
 682                        \restore the old configuration... "
 683         system ("cp " ++ conf_file ++ ".old " ++ conf_file)
 684         hPutStrLn stdout "done."
 685         throw e
 686     )
 687
 688 writeNewConfig :: String -> ([(String,Package)] -> [(String,Package)]) -> IO ()
 689 writeNewConfig conf_file fn = do
 690   hPutStr stdout "Writing new package config file... "
 691   old_details <- readIORef package_details
 692   h <- openFile conf_file WriteMode
 693   hPutStr h (dumpPackages (fn old_details))
 694   hClose h
 695   hPutStrLn stdout "done."
 696
 697 savePackageConfig :: String -> IO ()
 698 savePackageConfig conf_file = do
 699   hPutStr stdout "Saving old package config file... "
 700     -- mv rather than cp because we've already done an hGetContents
 701     -- on this file so we won't be able to open it for writing
 702     -- unless we move the old one out of the way...
 703   system ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old")
 704   hPutStrLn stdout "done."
 705
 706 -- package list is maintained in dependency order
 707 packages = global ["std", "rts", "gmp"] :: IORef [String]
 708 -- comma in value, so can't use macro, grrr
 709 {-# NOINLINE packages #-}
 710
 711 addPackage :: String -> IO ()
 712 addPackage package
 713   = do pkg_details <- readIORef package_details
 714        case lookup package pkg_details of
 715           Nothing -> throwDyn (OtherError ("unknown package name: " ++ package))
 716           Just details -> do
 717             ps <- readIORef packages
 718             unless (package `elem` ps) $ do
 719                 mapM_ addPackage (package_deps details)
 720                 ps <- readIORef packages
 721                 writeIORef packages (package:ps)
 722
 723 getPackageImportPath   :: IO [String]
 724 getPackageImportPath = do
 725   ps <- readIORef packages
 726   ps' <- getPackageDetails ps
 727   return (nub (concat (map import_dirs ps')))
 728
 729 getPackageIncludePath   :: IO [String]
 730 getPackageIncludePath = do
 731   ps <- readIORef packages
 732   ps' <- getPackageDetails ps
 733   return (nub (filter (not.null) (concatMap include_dirs ps')))
 734
 735         -- includes are in reverse dependency order (i.e. rts first)
 736 getPackageCIncludes   :: IO [String]
 737 getPackageCIncludes = do
 738   ps <- readIORef packages
 739   ps' <- getPackageDetails ps
 740   return (reverse (nub (filter (not.null) (concatMap c_includes ps'))))
 741
 742 getPackageLibraryPath  :: IO [String]
 743 getPackageLibraryPath = do
 744   ps <- readIORef packages
 745   ps' <- getPackageDetails ps
 746   return (nub (concat (map library_dirs ps')))
 747
 748 getPackageLibraries    :: IO [String]
 749 getPackageLibraries = do
 750   ps <- readIORef packages
 751   ps' <- getPackageDetails ps
 752   tag <- readIORef build_tag
 753   let suffix = if null tag then "" else '_':tag
 754   return (concat (
 755         map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps'
 756      ))
 757
 758 getPackageExtraGhcOpts :: IO [String]
 759 getPackageExtraGhcOpts = do
 760   ps <- readIORef packages
 761   ps' <- getPackageDetails ps
 762   return (concatMap extra_ghc_opts ps')
 763
 764 getPackageExtraCcOpts  :: IO [String]
 765 getPackageExtraCcOpts = do
 766   ps <- readIORef packages
 767   ps' <- getPackageDetails ps
 768   return (concatMap extra_cc_opts ps')
 769
 770 getPackageExtraLdOpts  :: IO [String]
 771 getPackageExtraLdOpts = do
 772   ps <- readIORef packages
 773   ps' <- getPackageDetails ps
 774   return (concatMap extra_ld_opts ps')
 775
 776 getPackageDetails :: [String] -> IO [Package]
 777 getPackageDetails ps = do
 778   pkg_details <- readIORef package_details
 779   return [ pkg | p <- ps, Just pkg <- [ lookup p pkg_details ] ]
 780
 781 GLOBAL_VAR(package_details, (error "package_details"), [(String,Package)])
 782
 783 -----------------------------------------------------------------------------
 784 -- Ways
 785
 786 -- The central concept of a "way" is that all objects in a given
 787 -- program must be compiled in the same "way".  Certain options change
 788 -- parameters of the virtual machine, eg. profiling adds an extra word
 789 -- to the object header, so profiling objects cannot be linked with
 790 -- non-profiling objects.
 791
 792 -- After parsing the command-line options, we determine which "way" we
 793 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
 794
 795 -- We then find the "build-tag" associated with this way, and this
 796 -- becomes the suffix used to find .hi files and libraries used in
 797 -- this compilation.
 798
 799 GLOBAL_VAR(build_tag, "", String)
 800
 801 data WayName
 802   = WayProf
 803   | WayUnreg
 804   | WayDll
 805   | WayTicky
 806   | WayPar
 807   | WayGran
 808   | WaySMP
 809   | WayDebug
 810   | WayUser_a
 811   | WayUser_b
 812   | WayUser_c
 813   | WayUser_d
 814   | WayUser_e
 815   | WayUser_f
 816   | WayUser_g
 817   | WayUser_h
 818   | WayUser_i
 819   | WayUser_j
 820   | WayUser_k
 821   | WayUser_l
 822   | WayUser_m
 823   | WayUser_n
 824   | WayUser_o
 825   | WayUser_A
 826   | WayUser_B
 827   deriving (Eq,Ord)
 828
 829 GLOBAL_VAR(ways, [] ,[WayName])
 830
 831 -- ToDo: allow WayDll with any other allowed combination
 832
 833 allowed_combinations =
 834    [  [WayProf,WayUnreg],
 835       [WayProf,WaySMP]     -- works???
 836    ]
 837
 838 findBuildTag :: IO [String]  -- new options
 839 findBuildTag = do
 840   way_names <- readIORef ways
 841   case sort way_names of
 842      []  -> do  writeIORef build_tag ""
 843                 return []
 844
 845      [w] -> do let details = lkupWay w
 846                writeIORef build_tag (wayTag details)
 847                return (wayOpts details)
 848
 849      ws  -> if  ws `notElem` allowed_combinations
 850                 then throwDyn (OtherError $
 851                                 "combination not supported: "  ++
 852                                 foldr1 (\a b -> a ++ '/':b)
 853                                 (map (wayName . lkupWay) ws))
 854                 else let stuff = map lkupWay ws
 855                          tag   = concat (map wayTag stuff)
 856                          flags = map wayOpts stuff
 857                      in do
 858                      writeIORef build_tag tag
 859                      return (concat flags)
 860
 861 lkupWay w =
 862    case lookup w way_details of
 863         Nothing -> error "findBuildTag"
 864         Just details -> details
 865
 866 data Way = Way {
 867   wayTag   :: String,
 868   wayName  :: String,
 869   wayOpts  :: [String]
 870   }
 871
 872 way_details :: [ (WayName, Way) ]
 873 way_details =
 874   [ (WayProf, Way  "p" "Profiling"
 875         [ "-fscc-profiling"
 876         , "-DPROFILING"
 877         , "-optc-DPROFILING"
 878         , "-fvia-C" ]),
 879
 880     (WayTicky, Way  "t" "Ticky-ticky Profiling"
 881         [ "-fticky-ticky"
 882         , "-DTICKY_TICKY"
 883         , "-optc-DTICKY_TICKY"
 884         , "-fvia-C" ]),
 885
 886     (WayUnreg, Way  "u" "Unregisterised"
 887         [ "-optc-DNO_REGS"
 888         , "-optc-DUSE_MINIINTERPRETER"
 889         , "-fno-asm-mangling"
 890         , "-funregisterised"
 891         , "-fvia-C" ]),
 892
 893     (WayDll, Way  "dll" "DLLized"
 894         [ ]),
 895
 896     (WayPar, Way  "mp" "Parallel"
 897         [ "-fstack-check"
 898         , "-fparallel"
 899         , "-D__PARALLEL_HASKELL__"
 900         , "-optc-DPAR"
 901         , "-package concurrent"
 902         , "-fvia-C" ]),
 903
 904     (WayGran, Way  "mg" "Gransim"
 905         [ "-fstack-check"
 906         , "-fgransim"
 907         , "-D__GRANSIM__"
 908         , "-optc-DGRAN"
 909         , "-package concurrent"
 910         , "-fvia-C" ]),
 911
 912     (WaySMP, Way  "s" "SMP"
 913         [ "-fsmp"
 914         , "-optc-pthread"
 915         , "-optl-pthread"
 916         , "-optc-DSMP"
 917         , "-fvia-C" ]),
 918
 919     (WayUser_a,  Way  "a"  "User way 'a'"  ["$WAY_a_REAL_OPTS"]),
 920     (WayUser_b,  Way  "b"  "User way 'b'"  ["$WAY_b_REAL_OPTS"]),
 921     (WayUser_c,  Way  "c"  "User way 'c'"  ["$WAY_c_REAL_OPTS"]),
 922     (WayUser_d,  Way  "d"  "User way 'd'"  ["$WAY_d_REAL_OPTS"]),
 923     (WayUser_e,  Way  "e"  "User way 'e'"  ["$WAY_e_REAL_OPTS"]),
 924     (WayUser_f,  Way  "f"  "User way 'f'"  ["$WAY_f_REAL_OPTS"]),
 925     (WayUser_g,  Way  "g"  "User way 'g'"  ["$WAY_g_REAL_OPTS"]),
 926     (WayUser_h,  Way  "h"  "User way 'h'"  ["$WAY_h_REAL_OPTS"]),
 927     (WayUser_i,  Way  "i"  "User way 'i'"  ["$WAY_i_REAL_OPTS"]),
 928     (WayUser_j,  Way  "j"  "User way 'j'"  ["$WAY_j_REAL_OPTS"]),
 929     (WayUser_k,  Way  "k"  "User way 'k'"  ["$WAY_k_REAL_OPTS"]),
 930     (WayUser_l,  Way  "l"  "User way 'l'"  ["$WAY_l_REAL_OPTS"]),
 931     (WayUser_m,  Way  "m"  "User way 'm'"  ["$WAY_m_REAL_OPTS"]),
 932     (WayUser_n,  Way  "n"  "User way 'n'"  ["$WAY_n_REAL_OPTS"]),
 933     (WayUser_o,  Way  "o"  "User way 'o'"  ["$WAY_o_REAL_OPTS"]),
 934     (WayUser_A,  Way  "A"  "User way 'A'"  ["$WAY_A_REAL_OPTS"]),
 935     (WayUser_B,  Way  "B"  "User way 'B'"  ["$WAY_B_REAL_OPTS"])
 936   ]
 937
 938 -----------------------------------------------------------------------------
 939 -- Programs for particular phases
 940
 941 GLOBAL_VAR(pgm_L,   findFile "unlit"      cGHC_UNLIT,      String)
 942 GLOBAL_VAR(pgm_P,   cRAWCPP,                               String)
 943 GLOBAL_VAR(pgm_C,   findFile "hsc"        cGHC_HSC,        String)
 944 GLOBAL_VAR(pgm_c,   cGCC,                                  String)
 945 GLOBAL_VAR(pgm_m,   findFile "ghc-asm"    cGHC_MANGLER,    String)
 946 GLOBAL_VAR(pgm_s,   findFile "ghc-split"  cGHC_SPLIT,      String)
 947 GLOBAL_VAR(pgm_a,   cGCC,                                  String)
 948 GLOBAL_VAR(pgm_l,   cGCC,                                  String)
 949
 950 -----------------------------------------------------------------------------
 951 -- Via-C compilation stuff
 952
 953 -- flags returned are: ( all C compilations
 954 --                     , registerised HC compilations
 955 --                     )
 956
 957 machdepCCOpts
 958    | prefixMatch "alpha"   cTARGETPLATFORM
 959         = return ( ["-static"], [] )
 960
 961    | prefixMatch "hppa"    cTARGETPLATFORM
 962         -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
 963         -- (very nice, but too bad the HP /usr/include files don't agree.)
 964         = return ( ["-static", "-D_HPUX_SOURCE"], [] )
 965
 966    | prefixMatch "m68k"    cTARGETPLATFORM
 967       -- -fno-defer-pop : for the .hc files, we want all the pushing/
 968       --    popping of args to routines to be explicit; if we let things
 969       --    be deferred 'til after an STGJUMP, imminent death is certain!
 970       --
 971       -- -fomit-frame-pointer : *don't*
 972       --     It's better to have a6 completely tied up being a frame pointer
 973       --     rather than let GCC pick random things to do with it.
 974       --     (If we want to steal a6, then we would try to do things
 975       --     as on iX86, where we *do* steal the frame pointer [%ebp].)
 976         = return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
 977
 978    | prefixMatch "i386"    cTARGETPLATFORM
 979       -- -fno-defer-pop : basically the same game as for m68k
 980       --
 981       -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
 982       --   the fp (%ebp) for our register maps.
 983         = do n_regs <- readState stolen_x86_regs
 984              sta    <- readIORef static
 985              return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" ],
 986                       [ "-fno-defer-pop", "-fomit-frame-pointer",
 987                         "-DSTOLEN_X86_REGS="++show n_regs ]
 988                     )
 989
 990    | prefixMatch "mips"    cTARGETPLATFORM
 991         = return ( ["static"], [] )
 992
 993    | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
 994         = return ( ["static"], ["-finhibit-size-directive"] )
 995
 996    | otherwise
 997         = return ( [], [] )
 998
 999 -----------------------------------------------------------------------------
1000 -- Build the Hsc command line
1001
1002 build_hsc_opts :: IO [String]
1003 build_hsc_opts = do
1004   opt_C_ <- getOpts opt_C               -- misc hsc opts
1005
1006         -- warnings
1007   warn_level <- readState warning_opt
1008   let warn_opts =  case warn_level of
1009                         W_default -> standardWarnings
1010                         W_        -> minusWOpts
1011                         W_all     -> minusWallOpts
1012                         W_not     -> []
1013
1014         -- optimisation
1015   minus_o <- readIORef opt_level
1016   optimisation_opts <-
1017         case minus_o of
1018             0 -> hsc_minusNoO_flags
1019             1 -> hsc_minusO_flags
1020             2 -> hsc_minusO2_flags
1021             _ -> error "unknown opt level"
1022             -- ToDo: -Ofile
1023
1024         -- STG passes
1025   ways_ <- readIORef ways
1026   let stg_massage | WayProf `elem` ways_ =  "-fmassage-stg-for-profiling"
1027                   | otherwise            = ""
1028
1029   stg_stats <- readIORef opt_StgStats
1030   let stg_stats_flag | stg_stats = "-dstg-stats"
1031                      | otherwise = ""
1032
1033   let stg_opts = [ stg_massage, stg_stats_flag, "-flet-no-escape" ]
1034         -- let-no-escape always on for now
1035
1036   verb <- is_verbose
1037   let hi_vers = "-fhi-version="++cProjectVersionInt
1038   static <- (do s <- readIORef static; if s then return "-static" else return "")
1039
1040   l <- readIORef hsc_lang
1041   let lang = case l of
1042                 HscC    -> "-olang=C"
1043                 HscAsm  -> "-olang=asm"
1044                 HscJava -> "-olang=java"
1045
1046   -- get hi-file suffix
1047   hisuf <- readIORef hi_suf
1048
1049   -- hi-suffix for packages depends on the build tag.
1050   package_hisuf <-
1051         do tag <- readIORef build_tag
1052            if null tag
1053                 then return "hi"
1054                 else return (tag ++ "_hi")
1055
1056   import_dirs <- readIORef import_paths
1057   package_import_dirs <- getPackageImportPath
1058
1059   let hi_map = "-himap=" ++
1060                 makeHiMap import_dirs hisuf
1061                          package_import_dirs package_hisuf
1062                          split_marker
1063
1064       hi_map_sep = "-himap-sep=" ++ [split_marker]
1065
1066   scale <- readIORef scale_sizes_by
1067   heap  <- readState specific_heap_size
1068   stack <- readState specific_stack_size
1069   cmdline_rts_opts <- getOpts opt_Crts
1070   let heap'  = truncate (fromIntegral heap  * scale) :: Integer
1071       stack' = truncate (fromIntegral stack * scale) :: Integer
1072       rts_opts = [ "+RTS", "-H"++show heap', "-K"++show stack' ]
1073                  ++ cmdline_rts_opts ++ [ "-RTS" ]
1074
1075   -- take into account -fno-* flags by removing the equivalent -f*
1076   -- flag from our list.
1077   anti_flags <- getOpts anti_opt_C
1078   let basic_opts = opt_C_ ++ warn_opts ++ optimisation_opts ++ stg_opts
1079       filtered_opts = filter (`notElem` anti_flags) basic_opts
1080
1081   return
1082         (
1083         filtered_opts
1084         -- ToDo: C stub files
1085         ++ [ hi_vers, static, verb, lang, hi_map, hi_map_sep ]
1086         ++ rts_opts
1087         )
1088
1089 makeHiMap
1090   (import_dirs         :: [String])
1091   (hi_suffix           :: String)
1092   (package_import_dirs :: [String])
1093   (package_hi_suffix   :: String)
1094   (split_marker        :: Char)
1095   = foldr (add_dir hi_suffix)
1096         (foldr (add_dir package_hi_suffix) "" package_import_dirs)
1097         import_dirs
1098   where
1099      add_dir hisuf dir str = dir ++ "%." ++ hisuf ++ split_marker : str
1100
1101
1102 getOptionsFromSource
1103         :: String               -- input file
1104         -> IO [String]          -- options, if any
1105 getOptionsFromSource file
1106   = do h <- openFile file ReadMode
1107        catchIO justIoErrors (look h)
1108           (\e -> if isEOFError e then return [] else ioError e)
1109   where
1110         look h = do
1111             l <- hGetLine h
1112             case () of
1113                 () | null l -> look h
1114                    | prefixMatch "#" l -> look h
1115                    | prefixMatch "{-# LINE" l -> look h
1116                    | Just (opts:_) <- matchRegex optionRegex l
1117                         -> return (words opts)
1118                    | otherwise -> return []
1119
1120 optionRegex = mkRegex "{-#[ \t]+OPTIONS[ \t]+(.*)#-}"
1121
1122 -----------------------------------------------------------------------------
1123 -- Main loop
1124
1125 get_source_files :: [String] -> ([String],[String])
1126 get_source_files = partition (('-' /=) . head)
1127
1128 main =
1129   -- all error messages are propagated as exceptions
1130   my_catchDyn (\dyn -> case dyn of
1131                           PhaseFailed _phase code -> exitWith code
1132                           Interrupted -> exitWith (ExitFailure 1)
1133                           _ -> do hPutStrLn stderr (show (dyn :: BarfKind))
1134                                   exitWith (ExitFailure 1)
1135               ) $
1136
1137   later cleanTempFiles $
1138         -- exceptions will be blocked while we clean the temporary files,
1139         -- so there shouldn't be any difficulty if we receive further
1140         -- signals.
1141
1142   do
1143         -- install signal handlers
1144    main_thread <- myThreadId
1145
1146 #ifndef mingw32_TARGET_OS
1147    let sig_handler = Catch (raiseInThread main_thread
1148                                 (DynException (toDyn Interrupted)))
1149    installHandler sigQUIT sig_handler Nothing
1150    installHandler sigINT  sig_handler Nothing
1151 #endif
1152
1153    pgm    <- getProgName
1154    writeIORef prog_name pgm
1155
1156    argv   <- getArgs
1157
1158         -- grab any -B options from the command line first
1159    argv'  <- setTopDir argv
1160
1161         -- read the package configuration
1162    conf_file <- readIORef package_config
1163    contents <- readFile conf_file
1164    writeIORef package_details (read contents)
1165
1166         -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
1167    (flags2, stop_phase, stop_flag, do_linking) <- getStopAfter argv'
1168
1169         -- process all the other arguments, and get the source files
1170    srcs <- processArgs driver_opts flags2 []
1171
1172         -- find the build tag, and re-process the build-specific options
1173    more_opts <- findBuildTag
1174    _ <- processArgs driver_opts more_opts []
1175
1176         -- get the -v flag
1177    verb <- readIORef verbose
1178
1179    when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))
1180
1181         -- mkdependHS is special
1182    when (stop_phase == MkDependHS) beginMkDependHS
1183
1184         -- for each source file, find which phases to run
1185    pipelines <- mapM (genPipeline stop_phase stop_flag) srcs
1186    let src_pipelines = zip srcs pipelines
1187
1188    o_file <- readIORef output_file
1189    if isJust o_file && not do_linking && length srcs > 1
1190         then throwDyn (UsageError "can't apply -o option to multiple source files")
1191         else do
1192
1193    if null srcs then throwDyn (UsageError "no input files") else do
1194
1195         -- save the flag state, because this could be modified by OPTIONS pragmas
1196         -- during the compilation, and we'll need to restore it before starting
1197         -- the next compilation.
1198    saved_driver_state <- readIORef driver_state
1199
1200    let compileFile (src, phases) = do
1201           r <- run_pipeline phases src do_linking True orig_base orig_suff
1202           writeIORef driver_state saved_driver_state
1203           return r
1204           where (orig_base, orig_suff) = splitFilename src
1205
1206    o_files <- mapM compileFile src_pipelines
1207
1208    when (stop_phase == MkDependHS) endMkDependHS
1209
1210    when do_linking (do_link o_files)
1211
1212 -----------------------------------------------------------------------------
1213 -- genPipeline
1214 --
1215 -- Herein is all the magic about which phases to run in which order, whether
1216 -- the intermediate files should be in /tmp or in the current directory,
1217 -- what the suffix of the intermediate files should be, etc.
1218
1219 -- The following compilation pipeline algorithm is fairly hacky.  A
1220 -- better way to do this would be to express the whole comilation as a
1221 -- data flow DAG, where the nodes are the intermediate files and the
1222 -- edges are the compilation phases.  This framework would also work
1223 -- nicely if a haskell dependency generator was included in the
1224 -- driver.
1225
1226 -- It would also deal much more cleanly with compilation phases that
1227 -- generate multiple intermediates, (eg. hsc generates .hc, .hi, and
1228 -- possibly stub files), where some of the output files need to be
1229 -- processed further (eg. the stub files need to be compiled by the C
1230 -- compiler).
1231
1232 -- A cool thing to do would then be to execute the data flow graph
1233 -- concurrently, automatically taking advantage of extra processors on
1234 -- the host machine.  For example, when compiling two Haskell files
1235 -- where one depends on the other, the data flow graph would determine
1236 -- that the C compiler from the first comilation can be overlapped
1237 -- with the hsc comilation for the second file.
1238
1239 data IntermediateFileType
1240   = Temporary
1241   | Persistent
1242   deriving (Eq)
1243
1244 -- the first compilation phase for a given file is determined
1245 -- by its suffix.
1246 startPhase "lhs"   = Unlit
1247 startPhase "hs"    = Cpp
1248 startPhase "hc"    = HCc
1249 startPhase "c"     = Cc
1250 startPhase "raw_s" = Mangle
1251 startPhase "s"     = As
1252 startPhase "S"     = As
1253 startPhase "o"     = Ln
1254 startPhase _       = Ln    -- all unknown file types
1255
1256 genPipeline
1257    :: Phase             -- stop after this phase
1258    -> String            -- "stop after" flag (for error messages)
1259    -> String            -- original filename
1260    -> IO [              -- list of phases to run for this file
1261              (Phase,
1262               IntermediateFileType,  -- keep the output from this phase?
1263               String)                -- output file suffix
1264          ]
1265
1266 genPipeline stop_after stop_after_flag filename
1267  = do
1268    split      <- readIORef split_object_files
1269    mangle     <- readIORef do_asm_mangling
1270    lang       <- readIORef hsc_lang
1271    keep_hc    <- readIORef keep_hc_files
1272    keep_raw_s <- readIORef keep_raw_s_files
1273    keep_s     <- readIORef keep_s_files
1274
1275    let
1276    ----------- -----  ----   ---   --   --  -  -  -
1277     start_phase = startPhase suffix
1278
1279     (_basename, suffix) = splitFilename filename
1280
1281     haskell_ish_file = suffix `elem` [ "hs", "lhs", "hc" ]
1282     c_ish_file       = suffix `elem` [ "c", "s", "S" ]  -- maybe .cc et al.??
1283
1284         -- hack for .hc files
1285     real_lang | suffix == "hc" = HscC
1286               | otherwise      = lang
1287
1288     pipeline
1289       | stop_after == MkDependHS =   [ Unlit, Cpp, MkDependHS ]
1290
1291       | haskell_ish_file =
1292        case real_lang of
1293         HscC    | split && mangle -> [ Unlit, Cpp, Hsc, HCc, Mangle,
1294                                         SplitMangle, SplitAs ]
1295                 | mangle          -> [ Unlit, Cpp, Hsc, HCc, Mangle, As ]
1296                 | split           -> not_valid
1297                 | otherwise       -> [ Unlit, Cpp, Hsc, HCc, As ]
1298
1299         HscAsm  | split           -> not_valid
1300                 | otherwise       -> [ Unlit, Cpp, Hsc, As ]
1301
1302         HscJava | split           -> not_valid
1303                 | otherwise       -> error "not implemented: compiling via Java"
1304
1305       | c_ish_file      = [ Cc, As ]
1306
1307       | otherwise       = [ ]  -- just pass this file through to the linker
1308
1309         -- ToDo: this is somewhat cryptic
1310     not_valid = throwDyn (OtherError ("invalid option combination"))
1311    ----------- -----  ----   ---   --   --  -  -  -
1312
1313         -- this shouldn't happen.
1314    if start_phase /= Ln && start_phase `notElem` pipeline
1315         then throwDyn (OtherError ("can't find starting phase for "
1316                                     ++ filename))
1317         else do
1318
1319         -- this might happen, eg.  ghc -S Foo.o
1320    if stop_after /= Ln && stop_after `notElem` pipeline
1321            && (stop_after /= As || SplitAs `notElem` pipeline)
1322         then throwDyn (OtherError ("flag " ++ stop_after_flag
1323                                    ++ " is incompatible with source file `"
1324                                    ++ filename ++ "'"))
1325         else do
1326
1327
1328    let
1329    ----------- -----  ----   ---   --   --  -  -  -
1330       annotatePipeline
1331          :: [Phase] -> Phase
1332          -> [(Phase, IntermediateFileType, String{-file extension-})]
1333       annotatePipeline []     _    = []
1334       annotatePipeline (Ln:_) _    = []
1335       annotatePipeline (phase:next_phase:ps) stop =
1336           (phase, keep_this_output, phase_input_ext next_phase)
1337              : annotatePipeline (next_phase:ps) stop
1338           where
1339                 keep_this_output
1340                      | phase == stop = Persistent
1341                      | otherwise =
1342                         case next_phase of
1343                              Ln -> Persistent
1344                              Mangle | keep_raw_s -> Persistent
1345                              As     | keep_s     -> Persistent
1346                              HCc    | keep_hc    -> Persistent
1347                              _other              -> Temporary
1348
1349         -- add information about output files to the pipeline
1350         -- the suffix on an output file is determined by the next phase
1351         -- in the pipeline, so we add linking to the end of the pipeline
1352         -- to force the output from the final phase to be a .o file.
1353       annotated_pipeline = annotatePipeline (pipeline ++ [ Ln ]) stop_after
1354
1355       phase_ne p (p1,_,_) = (p1 /= p)
1356    ----------- -----  ----   ---   --   --  -  -  -
1357
1358    return $
1359      dropWhile (phase_ne start_phase) .
1360         foldr (\p ps -> if phase_ne stop_after p then p:ps else [p])  []
1361                 $ annotated_pipeline
1362
1363
1364
1365 -- the output suffix for a given phase is uniquely determined by
1366 -- the input requirements of the next phase.
1367 phase_input_ext Unlit       = "lhs"
1368 phase_input_ext Cpp         = "lpp"
1369 phase_input_ext Hsc         = "cpp"
1370 phase_input_ext HCc         = "hc"
1371 phase_input_ext Cc          = "c"
1372 phase_input_ext Mangle      = "raw_s"
1373 phase_input_ext SplitMangle = "split_s" -- not really generated
1374 phase_input_ext As          = "s"
1375 phase_input_ext SplitAs     = "split_s" -- not really generated
1376 phase_input_ext Ln          = "o"
1377 phase_input_ext MkDependHS  = "dep"
1378
1379 run_pipeline
1380   :: [ (Phase, IntermediateFileType, String) ] -- phases to run
1381   -> String                     -- input file
1382   -> Bool                       -- doing linking afterward?
1383   -> Bool                       -- take into account -o when generating output?
1384   -> String                     -- original basename (eg. Main)
1385   -> String                     -- original suffix   (eg. hs)
1386   -> IO String                  -- return final filename
1387
1388 run_pipeline [] input_fn _ _ _ _ = return input_fn
1389 run_pipeline ((phase, keep, o_suffix):phases)
1390         input_fn do_linking use_ofile orig_basename orig_suffix
1391   = do
1392
1393      output_fn <-
1394         (if null phases && not do_linking && use_ofile
1395             then do o_file <- readIORef output_file
1396                     case o_file of
1397                         Just s  -> return s
1398                         Nothing -> do
1399                             f <- odir_ify (orig_basename ++ '.':o_suffix)
1400                             osuf_ify f
1401
1402             else if keep == Persistent
1403                         then odir_ify (orig_basename ++ '.':o_suffix)
1404                         else do filename <- newTempName o_suffix
1405                                 add files_to_clean filename
1406                                 return filename
1407         )
1408
1409      run_phase phase orig_basename orig_suffix input_fn output_fn
1410
1411         -- sadly, ghc -E is supposed to write the file to stdout.  We
1412         -- generate <file>.cpp, so we also have to cat the file here.
1413      when (null phases && phase == Cpp) $
1414         run_something "Dump pre-processed file to stdout"
1415                       ("cat " ++ output_fn)
1416
1417      run_pipeline phases output_fn do_linking use_ofile orig_basename orig_suffix
1418
1419
1420 -- find a temporary name that doesn't already exist.
1421 newTempName :: String -> IO String
1422 newTempName extn = do
1423   x <- getProcessID
1424   tmp_dir <- readIORef tmp_prefix
1425   findTempName tmp_dir x
1426   where findTempName tmp_dir x = do
1427            let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
1428            b  <- doesFileExist filename
1429            if b then findTempName tmp_dir (x+1)
1430                 else return filename
1431
1432 -------------------------------------------------------------------------------
1433 -- mkdependHS
1434
1435         -- flags
1436 GLOBAL_VAR(dep_makefile,        "Makefile", String);
1437 GLOBAL_VAR(dep_include_prelude, False, Bool);
1438 GLOBAL_VAR(dep_ignore_dirs,     [], [String]);
1439 GLOBAL_VAR(dep_suffixes,        [], [String]);
1440 GLOBAL_VAR(dep_warnings,        True, Bool);
1441
1442         -- global vars
1443 GLOBAL_VAR(dep_makefile_hdl,    error "dep_makefile_hdl", Maybe Handle);
1444 GLOBAL_VAR(dep_tmp_file,        error "dep_tmp_file", String);
1445 GLOBAL_VAR(dep_tmp_hdl,         error "dep_tmp_hdl", Handle);
1446 GLOBAL_VAR(dep_dir_contents,    error "dep_dir_contents", [(String,[String])]);
1447
1448 depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
1449 depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"
1450
1451 -- for compatibility with the old mkDependHS, we accept options of the form
1452 -- -optdep-f -optdep.depend, etc.
1453 dep_opts = [
1454    (  "s",      SepArg (add dep_suffixes) ),
1455    (  "f",      SepArg (writeIORef dep_makefile) ),
1456    (  "w",      NoArg (writeIORef dep_warnings False))
1457  ]
1458
1459 beginMkDependHS :: IO ()
1460 beginMkDependHS = do
1461
1462         -- slurp in the mkdependHS-style options
1463   flags <- getOpts opt_dep
1464   _ <- processArgs dep_opts flags []
1465
1466         -- open a new temp file in which to stuff the dependency info
1467         -- as we go along.
1468   dep_file <- newTempName "dep"
1469   add files_to_clean dep_file
1470   writeIORef dep_tmp_file dep_file
1471   tmp_hdl <- openFile dep_file WriteMode
1472   writeIORef dep_tmp_hdl tmp_hdl
1473
1474         -- open the makefile
1475   makefile <- readIORef dep_makefile
1476   exists <- doesFileExist makefile
1477   if not exists
1478         then do
1479            writeIORef dep_makefile_hdl Nothing
1480            return ()
1481
1482         else do
1483            makefile_hdl <- openFile makefile ReadMode
1484            writeIORef dep_makefile_hdl (Just makefile_hdl)
1485
1486                 -- slurp through until we get the magic start string,
1487                 -- copying the contents into dep_makefile
1488            let slurp = do
1489                 l <- hGetLine makefile_hdl
1490                 if (l == depStartMarker)
1491                         then return ()
1492                         else do hPutStrLn tmp_hdl l; slurp
1493
1494                 -- slurp through until we get the magic end marker,
1495                 -- throwing away the contents
1496            let chuck = do
1497                 l <- hGetLine makefile_hdl
1498                 if (l == depEndMarker)
1499                         then return ()
1500                         else chuck
1501
1502            catchIO justIoErrors slurp
1503                 (\e -> if isEOFError e then return () else ioError e)
1504            catchIO justIoErrors chuck
1505                 (\e -> if isEOFError e then return () else ioError e)
1506
1507
1508         -- write the magic marker into the tmp file
1509   hPutStrLn tmp_hdl depStartMarker
1510
1511         -- cache the contents of all the import directories, for future
1512         -- reference.
1513   import_dirs <- readIORef import_paths
1514   pkg_import_dirs <- getPackageImportPath
1515   import_dir_contents <- mapM getDirectoryContents import_dirs
1516   pkg_import_dir_contents <- mapM getDirectoryContents pkg_import_dirs
1517   writeIORef dep_dir_contents
1518         (zip import_dirs import_dir_contents ++
1519          zip pkg_import_dirs pkg_import_dir_contents)
1520
1521         -- ignore packages unless --include-prelude is on
1522   include_prelude <- readIORef dep_include_prelude
1523   when (not include_prelude) $
1524     mapM_ (add dep_ignore_dirs) pkg_import_dirs
1525
1526   return ()
1527
1528
1529 endMkDependHS :: IO ()
1530 endMkDependHS = do
1531   makefile     <- readIORef dep_makefile
1532   makefile_hdl <- readIORef dep_makefile_hdl
1533   tmp_file     <- readIORef dep_tmp_file
1534   tmp_hdl      <- readIORef dep_tmp_hdl
1535
1536         -- write the magic marker into the tmp file
1537   hPutStrLn tmp_hdl depEndMarker
1538
1539   case makefile_hdl of
1540      Nothing  -> return ()
1541      Just hdl -> do
1542
1543           -- slurp the rest of the orignal makefile and copy it into the output
1544         let slurp = do
1545                 l <- hGetLine hdl
1546                 hPutStrLn tmp_hdl l
1547                 slurp
1548
1549         catchIO justIoErrors slurp
1550                 (\e -> if isEOFError e then return () else ioError e)
1551
1552         hClose hdl
1553
1554   hClose tmp_hdl  -- make sure it's flushed
1555
1556         -- create a backup of the original makefile
1557   when (isJust makefile_hdl) $
1558      run_something ("Backing up " ++ makefile)
1559         (unwords [ "cp", makefile, makefile++".bak" ])
1560
1561         -- copy the new makefile in place
1562   run_something "Installing new makefile"
1563         (unwords [ "cp", tmp_file, makefile ])
1564
1565
1566 findDependency :: String -> Import -> IO (Maybe (String, Bool))
1567 findDependency mod imp = do
1568    dir_contents <- readIORef dep_dir_contents
1569    ignore_dirs  <- readIORef dep_ignore_dirs
1570    hisuf <- readIORef hi_suf
1571
1572    let
1573      (imp_mod, is_source) =
1574         case imp of
1575            Normal str -> (str, False)
1576            Source str -> (str, True )
1577
1578      imp_hi = imp_mod ++ '.':hisuf
1579      imp_hiboot = imp_mod ++ ".hi-boot"
1580      imp_hiboot_v = imp_mod ++ ".hi-boot-" ++ cHscIfaceFileVersion
1581      imp_hs = imp_mod ++ ".hs"
1582      imp_lhs = imp_mod ++ ".lhs"
1583
1584      deps | is_source = [ imp_hiboot_v, imp_hiboot, imp_hs, imp_lhs ]
1585           | otherwise = [ imp_hi, imp_hs, imp_lhs ]
1586
1587      search [] = throwDyn (OtherError ("can't find one of the following: " ++
1588                                       unwords (map (\d -> '`': d ++ "'") deps) ++
1589                                       " (imported from `" ++ mod ++ "')"))
1590      search ((dir, contents) : dirs)
1591            | null present = search dirs
1592            | otherwise =
1593                 if dir `elem` ignore_dirs
1594                         then return Nothing
1595                         else if is_source
1596                                 then if dep /= imp_hiboot_v
1597                                         then return (Just (dir++'/':imp_hiboot, False))
1598                                         else return (Just (dir++'/':dep, False))
1599                                 else return (Just (dir++'/':imp_hi, not is_source))
1600            where
1601                 present = filter (`elem` contents) deps
1602                 dep     = head present
1603
1604    -- in
1605    search dir_contents
1606
1607
1608 -------------------------------------------------------------------------------
1609 -- Unlit phase
1610
1611 run_phase Unlit _basename _suff input_fn output_fn
1612   = do unlit <- readIORef pgm_L
1613        unlit_flags <- getOpts opt_L
1614        run_something "Literate pre-processor"
1615           ("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
1616            ++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
1617
1618 -------------------------------------------------------------------------------
1619 -- Cpp phase
1620
1621 run_phase Cpp _basename _suff input_fn output_fn
1622   = do src_opts <- getOptionsFromSource input_fn
1623         -- ToDo: this is *wrong* if we're processing more than one file:
1624         -- the OPTIONS will persist through the subsequent compilations.
1625        _ <- processArgs driver_opts src_opts []
1626
1627        do_cpp <- readState cpp_flag
1628        if do_cpp
1629           then do
1630             cpp <- readIORef pgm_P
1631             hscpp_opts <- getOpts opt_P
1632             hs_src_cpp_opts <- readIORef hs_source_cpp_opts
1633
1634             cmdline_include_paths <- readIORef include_paths
1635             pkg_include_dirs <- getPackageIncludePath
1636             let include_paths = map (\p -> "-I"++p) (cmdline_include_paths
1637                                                         ++ pkg_include_dirs)
1638
1639             verb <- is_verbose
1640             run_something "C pre-processor"
1641                 (unwords
1642                    (["echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}'", ">", output_fn, "&&",
1643                      cpp, verb]
1644                     ++ include_paths
1645                     ++ hs_src_cpp_opts
1646                     ++ hscpp_opts
1647                     ++ [ "-x", "c", input_fn, ">>", output_fn ]
1648                    ))
1649           else do
1650             run_something "Inefective C pre-processor"
1651                    ("echo '{-# LINE 1 \""  ++ input_fn ++ "\" -}' > "
1652                     ++ output_fn ++ " && cat " ++ input_fn
1653                     ++ " >> " ++ output_fn)
1654
1655 -----------------------------------------------------------------------------
1656 -- MkDependHS phase
1657
1658 run_phase MkDependHS basename suff input_fn _output_fn = do
1659    src <- readFile input_fn
1660    let imports = getImports src
1661
1662    deps <- mapM (findDependency basename) imports
1663
1664    osuf_opt <- readIORef output_suf
1665    let osuf = case osuf_opt of
1666                         Nothing -> "o"
1667                         Just s  -> s
1668
1669    extra_suffixes <- readIORef dep_suffixes
1670    let suffixes = osuf : map (++ ('_':osuf)) extra_suffixes
1671        ofiles = map (\suf -> basename ++ '.':suf) suffixes
1672
1673    objs <- mapM odir_ify ofiles
1674
1675    hdl <- readIORef dep_tmp_hdl
1676
1677         -- std dependeny of the object(s) on the source file
1678    hPutStrLn hdl (unwords objs ++ " : " ++ basename ++ '.':suff)
1679
1680    let genDep (dep, False {- not an hi file -}) =
1681           hPutStrLn hdl (unwords objs ++ " : " ++ dep)
1682        genDep (dep, True  {- is an hi file -}) = do
1683           hisuf <- readIORef hi_suf
1684           let dep_base = remove_suffix '.' dep
1685               deps = (dep_base ++ hisuf)
1686                      : map (\suf -> dep_base ++ suf ++ '_':hisuf) extra_suffixes
1687                   -- length objs should be == length deps
1688           sequence_ (zipWith (\o d -> hPutStrLn hdl (o ++ " : " ++ d)) objs deps)
1689
1690    mapM genDep [ d | Just d <- deps ]
1691
1692    return ()
1693
1694 -- add the lines to dep_makefile:
1695            -- always:
1696                    -- this.o : this.hs
1697
1698            -- if the dependency is on something other than a .hi file:
1699                    -- this.o this.p_o ... : dep
1700            -- otherwise
1701                    -- if the import is {-# SOURCE #-}
1702                            -- this.o this.p_o ... : dep.hi-boot[-$vers]
1703
1704                    -- else
1705                            -- this.o ...   : dep.hi
1706                            -- this.p_o ... : dep.p_hi
1707                            -- ...
1708
1709            -- (where .o is $osuf, and the other suffixes come from
1710            -- the cmdline -s options).
1711
1712 -----------------------------------------------------------------------------
1713 -- Hsc phase
1714
1715 run_phase Hsc   basename _suff input_fn output_fn
1716   = do  hsc <- readIORef pgm_C
1717
1718   -- we add the current directory (i.e. the directory in which
1719   -- the .hs files resides) to the import path, since this is
1720   -- what gcc does, and it's probably what you want.
1721         let current_dir = getdir basename
1722
1723         paths <- readIORef include_paths
1724         writeIORef include_paths (current_dir : paths)
1725
1726   -- build the hsc command line
1727         hsc_opts <- build_hsc_opts
1728
1729         doing_hi <- readIORef produceHi
1730         tmp_hi_file <- if doing_hi
1731                           then do fn <- newTempName "hi"
1732                                   add files_to_clean fn
1733                                   return fn
1734                           else return ""
1735
1736   -- deal with -Rghc-timing
1737         timing <- readIORef collect_ghc_timing
1738         stat_file <- newTempName "stat"
1739         add files_to_clean stat_file
1740         let stat_opts | timing    = [ "+RTS", "-S"++stat_file, "-RTS" ]
1741                       | otherwise = []
1742
1743   -- tmp files for foreign export stub code
1744         tmp_stub_h <- newTempName "stub_h"
1745         tmp_stub_c <- newTempName "stub_c"
1746         add files_to_clean tmp_stub_h
1747         add files_to_clean tmp_stub_c
1748
1749   -- figure out where to put the .hi file
1750         ohi    <- readIORef output_hi
1751         hisuf  <- readIORef hi_suf
1752         let hi_flags = case ohi of
1753                            Nothing -> [ "-hidir="++current_dir, "-hisuf="++hisuf ]
1754                            Just fn -> [ "-hifile="++fn ]
1755
1756   -- run the compiler!
1757         run_something "Haskell Compiler"
1758                  (unwords (hsc : input_fn : (
1759                     hsc_opts
1760                     ++ hi_flags
1761                     ++ [
1762                           "-ofile="++output_fn,
1763                           "-F="++tmp_stub_c,
1764                           "-FH="++tmp_stub_h
1765                        ]
1766                     ++ stat_opts
1767                  )))
1768
1769   -- Generate -Rghc-timing info
1770         when (timing) (
1771             run_something "Generate timing stats"
1772                 (findFile "ghc-stats" cGHC_STATS ++ ' ':stat_file)
1773          )
1774
1775   -- Deal with stubs
1776         let stub_h = basename ++ "_stub.h"
1777         let stub_c = basename ++ "_stub.c"
1778
1779                 -- copy .h_stub file into current dir if present
1780         b <- doesFileExist tmp_stub_h
1781         when b (do
1782                 run_something "Copy stub .h file"
1783                                 ("cp " ++ tmp_stub_h ++ ' ':stub_h)
1784
1785                         -- #include <..._stub.h> in .hc file
1786                 addCmdlineHCInclude tmp_stub_h  -- hack
1787
1788                         -- copy the _stub.c file into the current dir
1789                 run_something "Copy stub .c file"
1790                     (unwords [
1791                         "rm -f", stub_c, "&&",
1792                         "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
1793                         "cat", tmp_stub_c, ">> ", stub_c
1794                         ])
1795
1796                         -- compile the _stub.c file w/ gcc
1797                 pipeline <- genPipeline As "" stub_c
1798                 run_pipeline pipeline stub_c False{-no linking-}
1799                                 False{-no -o option-}
1800                                 (basename++"_stub") "c"
1801
1802                 add ld_inputs (basename++"_stub.o")
1803          )
1804
1805 -----------------------------------------------------------------------------
1806 -- Cc phase
1807
1808 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
1809 -- way too many hacks, and I can't say I've ever used it anyway.
1810
1811 run_phase cc_phase _basename _suff input_fn output_fn
1812    | cc_phase == Cc || cc_phase == HCc
1813    = do cc <- readIORef pgm_c
1814         cc_opts <- (getOpts opt_c)
1815         cmdline_include_dirs <- readIORef include_paths
1816
1817         let hcc = cc_phase == HCc
1818
1819                 -- add package include paths even if we're just compiling
1820                 -- .c files; this is the Value Add(TM) that using
1821                 -- ghc instead of gcc gives you :)
1822         pkg_include_dirs <- getPackageIncludePath
1823         let include_paths = map (\p -> "-I"++p) (cmdline_include_dirs
1824                                                         ++ pkg_include_dirs)
1825
1826         c_includes <- getPackageCIncludes
1827         cmdline_includes <- readState cmdline_hc_includes -- -#include options
1828
1829         let cc_injects | hcc = unlines (map mk_include
1830                                         (c_includes ++ reverse cmdline_includes))
1831                        | otherwise = ""
1832             mk_include h_file =
1833                 case h_file of
1834                    '"':_{-"-} -> "#include "++h_file
1835                    '<':_      -> "#include "++h_file
1836                    _          -> "#include \""++h_file++"\""
1837
1838         cc_help <- newTempName "c"
1839         add files_to_clean cc_help
1840         h <- openFile cc_help WriteMode
1841         hPutStr h cc_injects
1842         hPutStrLn h ("#include \"" ++ input_fn ++ "\"\n")
1843         hClose h
1844
1845         ccout <- newTempName "ccout"
1846         add files_to_clean ccout
1847
1848         mangle <- readIORef do_asm_mangling
1849         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
1850
1851         verb <- is_verbose
1852
1853         o2 <- readIORef opt_minus_o2_for_C
1854         let opt_flag | o2        = "-O2"
1855                      | otherwise = "-O"
1856
1857         pkg_extra_cc_opts <- getPackageExtraCcOpts
1858
1859         excessPrecision <- readState excess_precision
1860
1861         run_something "C Compiler"
1862          (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
1863                    ++ md_c_flags
1864                    ++ (if cc_phase == HCc && mangle
1865                          then md_regd_c_flags
1866                          else [])
1867                    ++ [ verb, "-S", "-Wimplicit", opt_flag ]
1868                    ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
1869                    ++ cc_opts
1870 #ifdef mingw32_TARGET_OS
1871                    ++ [" -mno-cygwin"]
1872 #endif
1873                    ++ (if excessPrecision then [] else [ "-ffloat-store" ])
1874                    ++ include_paths
1875                    ++ pkg_extra_cc_opts
1876 --                 ++ [">", ccout]
1877                    ))
1878
1879         -- ToDo: postprocess the output from gcc
1880
1881 -----------------------------------------------------------------------------
1882 -- Mangle phase
1883
1884 run_phase Mangle _basename _suff input_fn output_fn
1885   = do mangler <- readIORef pgm_m
1886        mangler_opts <- getOpts opt_m
1887        machdep_opts <-
1888          if (prefixMatch "i386" cTARGETPLATFORM)
1889             then do n_regs <- readState stolen_x86_regs
1890                     return [ show n_regs ]
1891             else return []
1892        run_something "Assembly Mangler"
1893         (unwords (mangler :
1894                      mangler_opts
1895                   ++ [ input_fn, output_fn ]
1896                   ++ machdep_opts
1897                 ))
1898
1899 -----------------------------------------------------------------------------
1900 -- Splitting phase
1901
1902 run_phase SplitMangle _basename _suff input_fn _output_fn
1903   = do  splitter <- readIORef pgm_s
1904
1905         -- this is the prefix used for the split .s files
1906         tmp_pfx <- readIORef tmp_prefix
1907         x <- getProcessID
1908         let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
1909         writeIORef split_prefix split_s_prefix
1910         add files_to_clean (split_s_prefix ++ "__*") -- d:-)
1911
1912         -- allocate a tmp file to put the no. of split .s files in (sigh)
1913         n_files <- newTempName "n_files"
1914         add files_to_clean n_files
1915
1916         run_something "Split Assembly File"
1917          (unwords [ splitter
1918                   , input_fn
1919                   , split_s_prefix
1920                   , n_files ]
1921          )
1922
1923         -- save the number of split files for future references
1924         s <- readFile n_files
1925         let n = read s :: Int
1926         writeIORef n_split_files n
1927
1928 -----------------------------------------------------------------------------
1929 -- As phase
1930
1931 run_phase As _basename _suff input_fn output_fn
1932   = do  as <- readIORef pgm_a
1933         as_opts <- getOpts opt_a
1934
1935         cmdline_include_paths <- readIORef include_paths
1936         let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
1937         run_something "Assembler"
1938            (unwords (as : as_opts
1939                        ++ cmdline_include_flags
1940                        ++ [ "-c", input_fn, "-o",  output_fn ]
1941                     ))
1942
1943 run_phase SplitAs basename _suff _input_fn _output_fn
1944   = do  as <- readIORef pgm_a
1945         as_opts <- getOpts opt_a
1946
1947         split_s_prefix <- readIORef split_prefix
1948         n <- readIORef n_split_files
1949
1950         odir <- readIORef output_dir
1951         let real_odir = case odir of
1952                                 Nothing -> basename
1953                                 Just d  -> d
1954
1955         let assemble_file n = do
1956                     let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
1957                     let output_o = newdir real_odir
1958                                         (basename ++ "__" ++ show n ++ ".o")
1959                     real_o <- osuf_ify output_o
1960                     run_something "Assembler"
1961                             (unwords (as : as_opts
1962                                       ++ [ "-c", "-o", real_o, input_s ]
1963                             ))
1964
1965         mapM_ assemble_file [1..n]
1966
1967 -----------------------------------------------------------------------------
1968 -- Linking
1969
1970 do_link :: [String] -> IO ()
1971 do_link o_files = do
1972     ln <- readIORef pgm_l
1973     verb <- is_verbose
1974     o_file <- readIORef output_file
1975     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1976
1977     pkg_lib_paths <- getPackageLibraryPath
1978     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1979
1980     lib_paths <- readIORef library_paths
1981     let lib_path_opts = map ("-L"++) lib_paths
1982
1983     pkg_libs <- getPackageLibraries
1984     let pkg_lib_opts = map (\lib -> "-l"++lib) pkg_libs
1985
1986     libs <- readIORef cmdline_libraries
1987     let lib_opts = map ("-l"++) (reverse libs)
1988          -- reverse because they're added in reverse order from the cmd line
1989
1990     pkg_extra_ld_opts <- getPackageExtraLdOpts
1991
1992         -- probably _stub.o files
1993     extra_ld_inputs <- readIORef ld_inputs
1994
1995         -- opts from -optl-<blah>
1996     extra_ld_opts <- getOpts opt_l
1997
1998     run_something "Linker"
1999        (unwords
2000          ([ ln, verb, "-o", output_fn ]
2001          ++ o_files
2002          ++ extra_ld_inputs
2003          ++ lib_path_opts
2004          ++ lib_opts
2005          ++ pkg_lib_path_opts
2006          ++ pkg_lib_opts
2007          ++ pkg_extra_ld_opts
2008          ++ extra_ld_opts
2009         )
2010        )
2011
2012 -----------------------------------------------------------------------------
2013 -- Running an external program
2014
2015 run_something phase_name cmd
2016  = do
2017    verb <- readIORef verbose
2018    when verb $ do
2019         putStr phase_name
2020         putStrLn ":"
2021         putStrLn cmd
2022         hFlush stdout
2023
2024    -- test for -n flag
2025    n <- readIORef dry_run
2026    unless n $ do
2027
2028    -- and run it!
2029 #ifndef mingw32_TARGET_OS
2030    exit_code <- system cmd `catchAllIO`
2031                    (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
2032 #else
2033    tmp <- newTempName "sh"
2034    h <- openFile tmp WriteMode
2035    hPutStrLn h cmd
2036    hClose h
2037    exit_code <- system ("sh - " ++ tmp) `catchAllIO`
2038                    (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
2039    removeFile tmp
2040 #endif
2041
2042    if exit_code /= ExitSuccess
2043         then throwDyn (PhaseFailed phase_name exit_code)
2044         else do when verb (putStr "\n")
2045                 return ()
2046
2047 -----------------------------------------------------------------------------
2048 -- Flags
2049
2050 data OptKind
2051         = NoArg (IO ())                 -- flag with no argument
2052         | HasArg (String -> IO ())      -- flag has an argument (maybe prefix)
2053         | SepArg (String -> IO ())      -- flag has a separate argument
2054         | Prefix (String -> IO ())      -- flag is a prefix only
2055         | OptPrefix (String -> IO ())   -- flag may be a prefix
2056         | AnySuffix (String -> IO ())   -- flag is a prefix, pass whole arg to fn
2057         | PassFlag  (String -> IO ())   -- flag with no arg, pass flag to fn
2058
2059 -- note that ordering is important in the following list: any flag which
2060 -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
2061 -- flags further down the list with the same prefix.
2062
2063 driver_opts =
2064   [  ------- help -------------------------------------------------------
2065      ( "?"              , NoArg long_usage)
2066   ,  ( "-help"          , NoArg long_usage)
2067
2068
2069       ------- version ----------------------------------------------------
2070   ,  ( "-version"        , NoArg (do hPutStrLn stdout (cProjectName
2071                                       ++ ", version " ++ version_str)
2072                                      exitWith ExitSuccess))
2073   ,  ( "-numeric-version", NoArg (do hPutStrLn stdout version_str
2074                                      exitWith ExitSuccess))
2075
2076       ------- verbosity ----------------------------------------------------
2077   ,  ( "v"              , NoArg (writeIORef verbose True) )
2078   ,  ( "n"              , NoArg (writeIORef dry_run True) )
2079
2080         ------- recompilation checker --------------------------------------
2081   ,  ( "recomp"         , NoArg (writeIORef recomp True) )
2082   ,  ( "no-recomp"      , NoArg (writeIORef recomp False) )
2083
2084         ------- ways --------------------------------------------------------
2085   ,  ( "prof"           , NoArg (addNoDups ways WayProf) )
2086   ,  ( "unreg"          , NoArg (addNoDups ways WayUnreg) )
2087   ,  ( "dll"            , NoArg (addNoDups ways WayDll) )
2088   ,  ( "ticky"          , NoArg (addNoDups ways WayTicky) )
2089   ,  ( "parallel"       , NoArg (addNoDups ways WayPar) )
2090   ,  ( "gransim"        , NoArg (addNoDups ways WayGran) )
2091   ,  ( "smp"            , NoArg (addNoDups ways WaySMP) )
2092   ,  ( "debug"          , NoArg (addNoDups ways WayDebug) )
2093         -- ToDo: user ways
2094
2095         ------- Interface files ---------------------------------------------
2096   ,  ( "hi"             , NoArg (writeIORef produceHi True) )
2097   ,  ( "nohi"           , NoArg (writeIORef produceHi False) )
2098   ,  ( "hi-diffs"       , NoArg (writeIORef hi_diffs  NormalHiDiffs) )
2099   ,  ( "no-hi-diffs"    , NoArg (writeIORef hi_diffs  NoHiDiffs) )
2100   ,  ( "hi-diffs-with-usages" , NoArg (writeIORef hi_diffs UsageHiDiffs) )
2101   ,  ( "keep-hi-diffs"  , NoArg (writeIORef keep_hi_diffs True) )
2102         --"hi-with-*"    -> hiw <- readIORef hi_with  (ToDo)
2103
2104         --------- Profiling --------------------------------------------------
2105   ,  ( "auto-dicts"     , NoArg (addOpt_C "-fauto-sccs-on-dicts") )
2106   ,  ( "auto-all"       , NoArg (addOpt_C "-fauto-sccs-on-all-toplevs") )
2107   ,  ( "auto"           , NoArg (addOpt_C "-fauto-sccs-on-exported-toplevs") )
2108   ,  ( "caf-all"        , NoArg (addOpt_C "-fauto-sccs-on-individual-cafs") )
2109          -- "ignore-sccs"  doesn't work  (ToDo)
2110
2111         ------- Miscellaneous -----------------------------------------------
2112   ,  ( "cpp"            , NoArg (updateState (\s -> s{ cpp_flag = True })) )
2113   ,  ( "#include"       , HasArg (addCmdlineHCInclude) )
2114   ,  ( "no-link-chk"    , NoArg (return ()) ) -- ignored for backwards compat
2115
2116         ------- Output Redirection ------------------------------------------
2117   ,  ( "odir"           , HasArg (writeIORef output_dir  . Just) )
2118   ,  ( "o"              , SepArg (writeIORef output_file . Just) )
2119   ,  ( "osuf"           , HasArg (writeIORef output_suf  . Just) )
2120   ,  ( "hisuf"          , HasArg (writeIORef hi_suf) )
2121   ,  ( "tmpdir"         , HasArg (writeIORef tmp_prefix  . (++ "/")) )
2122   ,  ( "ohi"            , HasArg (\s -> case s of
2123                                           "-" -> writeIORef hi_on_stdout True
2124                                           _   -> writeIORef output_hi (Just s)) )
2125         -- -odump?
2126
2127   ,  ( "keep-hc-file"   , AnySuffix (\_ -> writeIORef keep_hc_files True) )
2128   ,  ( "keep-s-file"    , AnySuffix (\_ -> writeIORef keep_s_files  True) )
2129   ,  ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef keep_raw_s_files  True) )
2130   ,  ( "keep-tmp-files" , AnySuffix (\_ -> writeIORef keep_tmp_files True) )
2131
2132   ,  ( "split-objs"     , NoArg (if can_split
2133                                     then do writeIORef split_object_files True
2134                                             addOpt_C "-fglobalise-toplev-names"
2135                                             addOpt_c "-DUSE_SPLIT_MARKERS"
2136                                     else hPutStrLn stderr
2137                                             "warning: don't know how to  split \
2138                                             \object files on this architecture"
2139                                 ) )
2140
2141         ------- Include/Import Paths ----------------------------------------
2142   ,  ( "i"              , OptPrefix augment_import_paths )
2143   ,  ( "I"              , Prefix augment_include_paths )
2144
2145         ------- Libraries ---------------------------------------------------
2146   ,  ( "L"              , Prefix augment_library_paths )
2147   ,  ( "l"              , Prefix (add cmdline_libraries) )
2148
2149         ------- Packages ----------------------------------------------------
2150   ,  ( "package-name"   , HasArg (\s -> addOpt_C ("-inpackage="++s)) )
2151
2152   ,  ( "package"        , HasArg (addPackage) )
2153   ,  ( "syslib"         , HasArg (addPackage) ) -- for compatibility w/ old vsns
2154
2155   ,  ( "-list-packages"  , NoArg (listPackages) )
2156   ,  ( "-add-package"    , NoArg (newPackage) )
2157   ,  ( "-delete-package" , SepArg (deletePackage) )
2158
2159         ------- Specific phases  --------------------------------------------
2160   ,  ( "pgmL"           , HasArg (writeIORef pgm_L) )
2161   ,  ( "pgmP"           , HasArg (writeIORef pgm_P) )
2162   ,  ( "pgmC"           , HasArg (writeIORef pgm_C) )
2163   ,  ( "pgmc"           , HasArg (writeIORef pgm_c) )
2164   ,  ( "pgmm"           , HasArg (writeIORef pgm_m) )
2165   ,  ( "pgms"           , HasArg (writeIORef pgm_s) )
2166   ,  ( "pgma"           , HasArg (writeIORef pgm_a) )
2167   ,  ( "pgml"           , HasArg (writeIORef pgm_l) )
2168
2169   ,  ( "optdep"         , HasArg (addOpt_dep) )
2170   ,  ( "optL"           , HasArg (addOpt_L) )
2171   ,  ( "optP"           , HasArg (addOpt_P) )
2172   ,  ( "optCrts"        , HasArg (addOpt_Crts) )
2173   ,  ( "optC"           , HasArg (addOpt_C) )
2174   ,  ( "optc"           , HasArg (addOpt_c) )
2175   ,  ( "optm"           , HasArg (addOpt_m) )
2176   ,  ( "opta"           , HasArg (addOpt_a) )
2177   ,  ( "optl"           , HasArg (addOpt_l) )
2178   ,  ( "optdll"         , HasArg (addOpt_dll) )
2179
2180         ------ HsCpp opts ---------------------------------------------------
2181   ,  ( "D"              , Prefix (\s -> addOpt_P ("-D'"++s++"'") ) )
2182   ,  ( "U"              , Prefix (\s -> addOpt_P ("-U'"++s++"'") ) )
2183
2184         ------ Warning opts -------------------------------------------------
2185   ,  ( "W"              , NoArg (updateState (\s -> s{ warning_opt = W_ })))
2186   ,  ( "Wall"           , NoArg (updateState (\s -> s{ warning_opt = W_all })))
2187   ,  ( "Wnot"           , NoArg (updateState (\s -> s{ warning_opt = W_not })))
2188   ,  ( "w"              , NoArg (updateState (\s -> s{ warning_opt = W_not })))
2189
2190         ----- Linker --------------------------------------------------------
2191   ,  ( "static"         , NoArg (writeIORef static True) )
2192
2193         ------ Compiler RTS options -----------------------------------------
2194   ,  ( "H"                 , HasArg (newHeapSize  . decodeSize) )
2195   ,  ( "K"                 , HasArg (newStackSize . decodeSize) )
2196   ,  ( "Rscale-sizes"      , HasArg (floatOpt scale_sizes_by) )
2197   ,  ( "Rghc-timing"       , NoArg  (writeIORef collect_ghc_timing True) )
2198
2199         ------ Debugging ----------------------------------------------------
2200   ,  ( "dstg-stats"        , NoArg (writeIORef opt_StgStats True) )
2201
2202   ,  ( "dno-"              , Prefix (\s -> addAntiOpt_C ("-d"++s)) )
2203   ,  ( "d"                 , AnySuffix (addOpt_C) )
2204
2205         ------ Machine dependant (-m<blah>) stuff ---------------------------
2206
2207   ,  ( "monly-2-regs",          NoArg (updateState (\s -> s{stolen_x86_regs = 2}) ))
2208   ,  ( "monly-3-regs",          NoArg (updateState (\s -> s{stolen_x86_regs = 3}) ))
2209   ,  ( "monly-4-regs",          NoArg (updateState (\s -> s{stolen_x86_regs = 4}) ))
2210
2211         ------ Compiler flags -----------------------------------------------
2212   ,  ( "O2-for-C"          , NoArg (writeIORef opt_minus_o2_for_C True) )
2213   ,  ( "O"                 , OptPrefix (setOptLevel) )
2214
2215   ,  ( "fglasgow-exts-no-lang", NoArg ( do addOpt_C "-fglasgow-exts") )
2216
2217   ,  ( "fglasgow-exts"     , NoArg (do addOpt_C "-fglasgow-exts"
2218                                        addPackage "lang"))
2219
2220   ,  ( "fasm"              , OptPrefix (\_ -> writeIORef hsc_lang HscAsm) )
2221
2222   ,  ( "fvia-c"            , NoArg (writeIORef hsc_lang HscC) )
2223   ,  ( "fvia-C"            , NoArg (writeIORef hsc_lang HscC) )
2224
2225   ,  ( "fno-asm-mangling"  , NoArg (writeIORef do_asm_mangling False) )
2226
2227   ,  ( "fmax-simplifier-iterations",
2228                 Prefix (writeIORef opt_MaxSimplifierIterations . read) )
2229
2230   ,  ( "fusagesp"          , NoArg (do writeIORef opt_UsageSPInf True
2231                                        addOpt_C "-fusagesp-on") )
2232
2233   ,  ( "fexcess-precision" , NoArg (do updateState
2234                                            (\s -> s{ excess_precision = True })
2235                                        addOpt_C "-fexcess-precision"))
2236
2237         -- flags that are "active negatives"
2238   ,  ( "fno-implicit-prelude"   , PassFlag (addOpt_C) )
2239   ,  ( "fno-prune-tydecls"      , PassFlag (addOpt_C) )
2240   ,  ( "fno-prune-instdecls"    , PassFlag (addOpt_C) )
2241   ,  ( "fno-pre-inlining"       , PassFlag (addOpt_C) )
2242
2243         -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
2244   ,  ( "fno-",                  Prefix (\s -> addAntiOpt_C ("-f"++s)) )
2245
2246         -- Pass all remaining "-f<blah>" options to hsc
2247   ,  ( "f",                     AnySuffix (addOpt_C) )
2248   ]
2249
2250 -----------------------------------------------------------------------------
2251 -- Process command-line
2252
2253 processArgs :: [(String,OptKind)] -> [String] -> [String]
2254    -> IO [String]  -- returns spare args
2255 processArgs _spec [] spare = return (reverse spare)
2256 processArgs spec args@(('-':_):_) spare = do
2257   args' <- processOneArg spec args
2258   processArgs spec args' spare
2259 processArgs spec (arg:args) spare =
2260   processArgs spec args (arg:spare)
2261
2262 processOneArg :: [(String,OptKind)] -> [String] -> IO [String]
2263 processOneArg spec (('-':arg):args) = do
2264   let (rest,action) = findArg spec arg
2265       dash_arg = '-':arg
2266   case action of
2267
2268         NoArg  io ->
2269                 if rest == ""
2270                         then io >> return args
2271                         else unknownFlagErr dash_arg
2272
2273         HasArg fio ->
2274                 if rest /= ""
2275                         then fio rest >> return args
2276                         else case args of
2277                                 [] -> unknownFlagErr dash_arg
2278                                 (arg1:args1) -> fio arg1 >> return args1
2279
2280         SepArg fio ->
2281                 case args of
2282                         [] -> unknownFlagErr dash_arg
2283                         (arg1:args1) -> fio arg1 >> return args1
2284
2285         Prefix fio ->
2286                 if rest /= ""
2287                         then fio rest >> return args
2288                         else unknownFlagErr dash_arg
2289
2290         OptPrefix fio -> fio rest >> return args
2291
2292         AnySuffix fio -> fio ('-':arg) >> return args
2293
2294         PassFlag fio  ->
2295                 if rest /= ""
2296                         then unknownFlagErr dash_arg
2297                         else fio ('-':arg) >> return args
2298
2299 findArg :: [(String,OptKind)] -> String -> (String,OptKind)
2300 findArg spec arg
2301   = case [ (remove_spaces rest, k) | (pat,k) <- spec,
2302                                      Just rest <- [my_prefix_match pat arg],
2303                                      is_prefix k || null rest ] of
2304         [] -> unknownFlagErr ('-':arg)
2305         (one:_) -> one
2306
2307 is_prefix (NoArg _) = False
2308 is_prefix (SepArg _) = False
2309 is_prefix (PassFlag _) = False
2310 is_prefix _ = True
2311
2312 -----------------------------------------------------------------------------
2313 -- convert sizes like "3.5M" into integers
2314
2315 decodeSize :: String -> Integer
2316 decodeSize str
2317   | c == ""              = truncate n
2318   | c == "K" || c == "k" = truncate (n * 1000)
2319   | c == "M" || c == "m" = truncate (n * 1000 * 1000)
2320   | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
2321   | otherwise            = throwDyn (OtherError ("can't decode size: " ++ str))
2322   where (m, c) = span pred str
2323         n      = read m  :: Double
2324         pred c = isDigit c || c == '.'
2325
2326 floatOpt :: IORef Double -> String -> IO ()
2327 floatOpt ref str
2328   = writeIORef ref (read str :: Double)
2329
2330 -----------------------------------------------------------------------------
2331 -- Finding files in the installation
2332
2333 GLOBAL_VAR(topDir, clibdir, String)
2334
2335         -- grab the last -B option on the command line, and
2336         -- set topDir to its value.
2337 setTopDir :: [String] -> IO [String]
2338 setTopDir args = do
2339   let (minusbs, others) = partition (prefixMatch "-B") args
2340   (case minusbs of
2341     []   -> writeIORef topDir clibdir
2342     some -> writeIORef topDir (drop 2 (last some)))
2343   return others
2344
2345 findFile name alt_path = unsafePerformIO (do
2346   top_dir <- readIORef topDir
2347   let installed_file = top_dir ++ '/':name
2348   let inplace_file   = top_dir ++ '/':cCURRENT_DIR ++ '/':alt_path
2349   b <- doesFileExist inplace_file
2350   if b  then return inplace_file
2351         else return installed_file
2352  )
2353
2354 -----------------------------------------------------------------------------
2355 -- Utils
2356
2357 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
2358 my_partition _ [] = ([],[])
2359 my_partition p (a:as)
2360   = let (bs,cs) = my_partition p as in
2361     case p a of
2362         Nothing -> (bs,a:cs)
2363         Just b  -> ((a,b):bs,cs)
2364
2365 my_prefix_match :: String -> String -> Maybe String
2366 my_prefix_match [] rest = Just rest
2367 my_prefix_match (_:_) [] = Nothing
2368 my_prefix_match (p:pat) (r:rest)
2369   | p == r    = my_prefix_match pat rest
2370   | otherwise = Nothing
2371
2372 prefixMatch :: Eq a => [a] -> [a] -> Bool
2373 prefixMatch [] _str = True
2374 prefixMatch _pat [] = False
2375 prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
2376                           | otherwise = False
2377
2378 postfixMatch :: String -> String -> Bool
2379 postfixMatch pat str = prefixMatch (reverse pat) (reverse str)
2380
2381 later = flip finally
2382
2383 my_catchDyn = flip catchDyn
2384
2385 global :: a -> IORef a
2386 global a = unsafePerformIO (newIORef a)
2387
2388 splitFilename :: String -> (String,String)
2389 splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext)
2390   where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
2391         stripDot ('.':xs) = xs
2392         stripDot xs       = xs
2393
2394 suffixOf :: String -> String
2395 suffixOf s = drop_longest_prefix s '.'
2396
2397 split :: Char -> String -> [String]
2398 split c s = case rest of
2399                 []     -> [chunk]
2400                 _:rest -> chunk : split c rest
2401   where (chunk, rest) = break (==c) s
2402
2403 add :: IORef [a] -> a -> IO ()
2404 add var x = do
2405   xs <- readIORef var
2406   writeIORef var (x:xs)
2407
2408 addNoDups :: Eq a => IORef [a] -> a -> IO ()
2409 addNoDups var x = do
2410   xs <- readIORef var
2411   unless (x `elem` xs) $ writeIORef var (x:xs)
2412
2413 remove_suffix :: Char -> String -> String
2414 remove_suffix c s
2415   | null pre  = reverse suf
2416   | otherwise = reverse pre
2417   where (suf,pre) = break (==c) (reverse s)
2418
2419 drop_longest_prefix :: String -> Char -> String
2420 drop_longest_prefix s c = reverse suf
2421   where (suf,_pre) = break (==c) (reverse s)
2422
2423 take_longest_prefix :: String -> Char -> String
2424 take_longest_prefix s c = reverse pre
2425   where (_suf,pre) = break (==c) (reverse s)
2426
2427 newsuf :: String -> String -> String
2428 newsuf suf s = remove_suffix '.' s ++ suf
2429
2430 -- getdir strips the filename off the input string, returning the directory.
2431 getdir :: String -> String
2432 getdir s = if null dir then "." else init dir
2433   where dir = take_longest_prefix s '/'
2434
2435 newdir :: String -> String -> String
2436 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
2437
2438 remove_spaces :: String -> String
2439 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace