ghc/driver/Main.hs

   1 {-# OPTIONS -W #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: Main.hs,v 1.49 2000/08/04 09:45:20 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 -- Global compilation flags
 272
 273         -- Cpp-related flags
 274 hs_source_cpp_opts = global
 275         [ "-D__HASKELL1__="++cHaskell1Version
 276         , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
 277         , "-D__HASKELL98__"
 278         , "-D__CONCURRENT_HASKELL__"
 279         ]
 280
 281         -- Verbose
 282 GLOBAL_VAR(verbose, False, Bool)
 283 is_verbose = do v <- readIORef verbose; if v then return "-v" else return ""
 284
 285         -- Keep output from intermediate phases
 286 GLOBAL_VAR(keep_hi_diffs,       False,          Bool)
 287 GLOBAL_VAR(keep_hc_files,       False,          Bool)
 288 GLOBAL_VAR(keep_s_files,        False,          Bool)
 289 GLOBAL_VAR(keep_raw_s_files,    False,          Bool)
 290
 291         -- Misc
 292 GLOBAL_VAR(scale_sizes_by,      1.0,            Double)
 293 GLOBAL_VAR(dry_run,             False,          Bool)
 294 GLOBAL_VAR(recomp,              True,           Bool)
 295 GLOBAL_VAR(tmp_prefix,          cTMPDIR,        String)
 296 #if !defined(HAVE_WIN32_DLL_SUPPORT) || defined(DONT_WANT_WIN32_DLL_SUPPORT)
 297 GLOBAL_VAR(static,              True,           Bool)
 298 #else
 299 GLOBAL_VAR(static,              False,          Bool)
 300 #endif
 301 GLOBAL_VAR(collect_ghc_timing,  False,          Bool)
 302 GLOBAL_VAR(do_asm_mangling,     True,           Bool)
 303
 304 -----------------------------------------------------------------------------
 305 -- Splitting object files (for libraries)
 306
 307 GLOBAL_VAR(split_object_files,  False,          Bool)
 308 GLOBAL_VAR(split_prefix,        "",             String)
 309 GLOBAL_VAR(n_split_files,       0,              Int)
 310
 311 can_split :: Bool
 312 can_split =  prefixMatch "i386" cTARGETPLATFORM
 313           || prefixMatch "alpha" cTARGETPLATFORM
 314           || prefixMatch "hppa" cTARGETPLATFORM
 315           || prefixMatch "m68k" cTARGETPLATFORM
 316           || prefixMatch "mips" cTARGETPLATFORM
 317           || prefixMatch "powerpc" cTARGETPLATFORM
 318           || prefixMatch "rs6000" cTARGETPLATFORM
 319           || prefixMatch "sparc" cTARGETPLATFORM
 320
 321 -----------------------------------------------------------------------------
 322 -- Compiler output options
 323
 324 data HscLang
 325   = HscC
 326   | HscAsm
 327   | HscJava
 328
 329 GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" &&
 330                          (prefixMatch "i386" cTARGETPLATFORM ||
 331                           prefixMatch "sparc" cTARGETPLATFORM)
 332                         then  HscAsm
 333                         else  HscC,
 334            HscLang)
 335
 336 GLOBAL_VAR(output_dir,  Nothing, Maybe String)
 337 GLOBAL_VAR(output_suf,  Nothing, Maybe String)
 338 GLOBAL_VAR(output_file, Nothing, Maybe String)
 339 GLOBAL_VAR(output_hi,   Nothing, Maybe String)
 340
 341 GLOBAL_VAR(ld_inputs,   [],      [String])
 342
 343 odir_ify :: String -> IO String
 344 odir_ify f = do
 345   odir_opt <- readIORef output_dir
 346   case odir_opt of
 347         Nothing -> return f
 348         Just d  -> return (newdir d f)
 349
 350 osuf_ify :: String -> IO String
 351 osuf_ify f = do
 352   osuf_opt <- readIORef output_suf
 353   case osuf_opt of
 354         Nothing -> return f
 355         Just s  -> return (newsuf s f)
 356
 357 -----------------------------------------------------------------------------
 358 -- Hi Files
 359
 360 GLOBAL_VAR(produceHi,           True,   Bool)
 361 GLOBAL_VAR(hi_on_stdout,        False,  Bool)
 362 GLOBAL_VAR(hi_with,             "",     String)
 363 GLOBAL_VAR(hi_suf,              "hi",   String)
 364
 365 data HiDiffFlag = NormalHiDiffs | UsageHiDiffs | NoHiDiffs
 366 GLOBAL_VAR(hi_diffs, NoHiDiffs, HiDiffFlag)
 367
 368 -----------------------------------------------------------------------------
 369 -- Warnings & sanity checking
 370
 371 -- Warning packages that are controlled by -W and -Wall.  The 'standard'
 372 -- warnings that you get all the time are
 373 --
 374 --         -fwarn-overlapping-patterns
 375 --         -fwarn-missing-methods
 376 --         -fwarn-missing-fields
 377 --         -fwarn-deprecations
 378 --         -fwarn-duplicate-exports
 379 --
 380 -- these are turned off by -Wnot.
 381
 382 standardWarnings  = [ "-fwarn-overlapping-patterns"
 383                     , "-fwarn-missing-methods"
 384                     , "-fwarn-missing-fields"
 385                     , "-fwarn-deprecations"
 386                     , "-fwarn-duplicate-exports"
 387                     ]
 388 minusWOpts        = standardWarnings ++
 389                     [ "-fwarn-unused-binds"
 390                     , "-fwarn-unused-matches"
 391                     , "-fwarn-incomplete-patterns"
 392                     , "-fwarn-unused-imports"
 393                     ]
 394 minusWallOpts     = minusWOpts ++
 395                     [ "-fwarn-type-defaults"
 396                     , "-fwarn-name-shadowing"
 397                     , "-fwarn-missing-signatures"
 398                     ]
 399
 400 data WarningState = W_default | W_ | W_all | W_not
 401
 402 -----------------------------------------------------------------------------
 403 -- Compiler optimisation options
 404
 405 GLOBAL_VAR(opt_level, 0, Int)
 406
 407 setOptLevel :: String -> IO ()
 408 setOptLevel ""              = do { writeIORef opt_level 1; go_via_C }
 409 setOptLevel "not"           = writeIORef opt_level 0
 410 setOptLevel [c] | isDigit c = do
 411    let level = ord c - ord '0'
 412    writeIORef opt_level level
 413    when (level >= 1) go_via_C
 414 setOptLevel s = unknownFlagErr ("-O"++s)
 415
 416 go_via_C = do
 417    l <- readIORef hsc_lang
 418    case l of { HscAsm -> writeIORef hsc_lang HscC;
 419                _other -> return () }
 420
 421 GLOBAL_VAR(opt_minus_o2_for_C, False, Bool)
 422
 423 GLOBAL_VAR(opt_MaxSimplifierIterations, 4, Int)
 424 GLOBAL_VAR(opt_StgStats,    False, Bool)
 425 GLOBAL_VAR(opt_UsageSPInf,  False, Bool)  -- Off by default
 426
 427 hsc_minusO2_flags = hsc_minusO_flags    -- for now
 428
 429 hsc_minusNoO_flags = do
 430   iter        <- readIORef opt_MaxSimplifierIterations
 431   return [
 432         "-fignore-interface-pragmas",
 433         "-fomit-interface-pragmas",
 434         "-fsimplify",
 435             "[",
 436                 "-fmax-simplifier-iterations" ++ show iter,
 437             "]"
 438         ]
 439
 440 hsc_minusO_flags = do
 441   iter       <- readIORef opt_MaxSimplifierIterations
 442   usageSP    <- readIORef opt_UsageSPInf
 443   stgstats   <- readIORef opt_StgStats
 444
 445   return [
 446         "-ffoldr-build-on",
 447
 448         "-fdo-eta-reduction",
 449         "-fdo-lambda-eta-expansion",
 450         "-fcase-of-case",
 451         "-fcase-merge",
 452         "-flet-to-case",
 453
 454         -- initial simplify: mk specialiser happy: minimum effort please
 455
 456         "-fsimplify",
 457           "[",
 458                 "-finline-phase0",
 459                         -- Don't inline anything till full laziness has bitten
 460                         -- In particular, inlining wrappers inhibits floating
 461                         -- e.g. ...(case f x of ...)...
 462                         --  ==> ...(case (case x of I# x# -> fw x#) of ...)...
 463                         --  ==> ...(case x of I# x# -> case fw x# of ...)...
 464                         -- and now the redex (f x) isn't floatable any more
 465
 466                 "-fno-rules",
 467                         -- Similarly, don't apply any rules until after full
 468                         -- laziness.  Notably, list fusion can prevent floating.
 469
 470                 "-fno-case-of-case",
 471                         -- Don't do case-of-case transformations.
 472                         -- This makes full laziness work better
 473
 474                 "-fmax-simplifier-iterations2",
 475           "]",
 476
 477         -- Specialisation is best done before full laziness
 478         -- so that overloaded functions have all their dictionary lambdas manifest
 479         "-fspecialise",
 480
 481         "-ffloat-outwards",
 482         "-ffloat-inwards",
 483
 484         "-fsimplify",
 485           "[",
 486                 "-finline-phase1",
 487                 -- Want to run with inline phase 1 after the specialiser to give
 488                 -- maximum chance for fusion to work before we inline build/augment
 489                 -- in phase 2.  This made a difference in 'ansi' where an
 490                 -- overloaded function wasn't inlined till too late.
 491                 "-fmax-simplifier-iterations" ++ show iter,
 492           "]",
 493
 494         -- infer usage information here in case we need it later.
 495         -- (add more of these where you need them --KSW 1999-04)
 496         if usageSP then "-fusagesp" else "",
 497
 498         "-fsimplify",
 499           "[",
 500                 -- Need inline-phase2 here so that build/augment get
 501                 -- inlined.  I found that spectral/hartel/genfft lost some useful
 502                 -- strictness in the function sumcode' if augment is not inlined
 503                 -- before strictness analysis runs
 504
 505                 "-finline-phase2",
 506                 "-fmax-simplifier-iterations2",
 507           "]",
 508
 509
 510         "-fsimplify",
 511           "[",
 512                 "-fmax-simplifier-iterations2",
 513                 -- No -finline-phase: allow all Ids to be inlined now
 514                 -- This gets foldr inlined before strictness analysis
 515           "]",
 516
 517         "-fstrictness",
 518         "-fcpr-analyse",
 519         "-fworker-wrapper",
 520
 521         "-fsimplify",
 522           "[",
 523                 "-fmax-simplifier-iterations" ++ show iter,
 524                 -- No -finline-phase: allow all Ids to be inlined now
 525           "]",
 526
 527         "-ffloat-outwards",
 528                 -- nofib/spectral/hartel/wang doubles in speed if you
 529                 -- do full laziness late in the day.  It only happens
 530                 -- after fusion and other stuff, so the early pass doesn't
 531                 -- catch it.  For the record, the redex is
 532                 --        f_el22 (f_el21 r_midblock)
 533
 534 -- Leave out lambda lifting for now
 535 --        "-fsimplify", -- Tidy up results of full laziness
 536 --          "[",
 537 --                "-fmax-simplifier-iterations2",
 538 --          "]",
 539 --        "-ffloat-outwards-full",
 540
 541         -- We want CSE to follow the final full-laziness pass, because it may
 542         -- succeed in commoning up things floated out by full laziness.
 543         --
 544         -- CSE must immediately follow a simplification pass, because it relies
 545         -- on the no-shadowing invariant.  See comments at the top of CSE.lhs
 546         -- So it must NOT follow float-inwards, which can give rise to shadowing,
 547         -- even if its input doesn't have shadows.  Hence putting it between
 548         -- the two passes.
 549         "-fcse",
 550
 551
 552         "-ffloat-inwards",
 553
 554 -- Case-liberation for -O2.  This should be after
 555 -- strictness analysis and the simplification which follows it.
 556
 557 --        ( ($OptLevel != 2)
 558 --        ? ""
 559 --        : "-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 ]" ),
 560 --
 561 --        "-fliberate-case",
 562
 563         -- Final clean-up simplification:
 564         "-fsimplify",
 565           "[",
 566                 "-fmax-simplifier-iterations" ++ show iter,
 567                 -- No -finline-phase: allow all Ids to be inlined now
 568           "]"
 569
 570         ]
 571
 572 -----------------------------------------------------------------------------
 573 -- Paths & Libraries
 574
 575 split_marker = ':'   -- not configurable (ToDo)
 576
 577 import_paths, include_paths, library_paths :: IORef [String]
 578 GLOBAL_VAR(import_paths,  ["."], [String])
 579 GLOBAL_VAR(include_paths, ["."], [String])
 580 GLOBAL_VAR(library_paths, [],    [String])
 581
 582 GLOBAL_VAR(cmdline_libraries,   [], [String])
 583
 584 addToDirList :: IORef [String] -> String -> IO ()
 585 addToDirList ref path
 586   = do paths <- readIORef ref
 587        writeIORef ref (paths ++ split split_marker path)
 588
 589 -----------------------------------------------------------------------------
 590 -- Packages
 591
 592 GLOBAL_VAR(package_config, (findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")), String)
 593
 594 listPackages :: IO ()
 595 listPackages = do
 596   details <- readIORef package_details
 597   hPutStr stdout (listPkgs details)
 598   hPutChar stdout '\n'
 599   exitWith ExitSuccess
 600
 601 newPackage :: IO ()
 602 newPackage = do
 603   checkConfigAccess
 604   details <- readIORef package_details
 605   hPutStr stdout "Reading package info from stdin... "
 606   stuff <- getContents
 607   let new_pkg = read stuff :: (String,Package)
 608   catchAll new_pkg
 609         (\_ -> throwDyn (OtherError "parse error in package info"))
 610   hPutStrLn stdout "done."
 611   if (fst new_pkg `elem` map fst details)
 612         then throwDyn (OtherError ("package `" ++ fst new_pkg ++
 613                                         "' already installed"))
 614         else do
 615   conf_file <- readIORef package_config
 616   savePackageConfig conf_file
 617   maybeRestoreOldConfig conf_file $ do
 618   writeNewConfig conf_file ( ++ [new_pkg])
 619   exitWith ExitSuccess
 620
 621 deletePackage :: String -> IO ()
 622 deletePackage pkg = do
 623   checkConfigAccess
 624   details <- readIORef package_details
 625   if (pkg `notElem` map fst details)
 626         then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
 627         else do
 628   conf_file <- readIORef package_config
 629   savePackageConfig conf_file
 630   maybeRestoreOldConfig conf_file $ do
 631   writeNewConfig conf_file (filter ((/= pkg) . fst))
 632   exitWith ExitSuccess
 633
 634 checkConfigAccess :: IO ()
 635 checkConfigAccess = do
 636   conf_file <- readIORef package_config
 637   access <- getPermissions conf_file
 638   unless (writable access)
 639         (throwDyn (OtherError "you don't have permission to modify the package configuration file"))
 640
 641 maybeRestoreOldConfig :: String -> IO () -> IO ()
 642 maybeRestoreOldConfig conf_file io
 643   = catchAllIO io (\e -> do
 644         hPutStr stdout "\nWARNING: an error was encountered while the new \n\
 645                        \configuration was being written.  Attempting to \n\
 646                        \restore the old configuration... "
 647         system ("cp " ++ conf_file ++ ".old " ++ conf_file)
 648         hPutStrLn stdout "done."
 649         throw e
 650     )
 651
 652 writeNewConfig :: String -> ([(String,Package)] -> [(String,Package)]) -> IO ()
 653 writeNewConfig conf_file fn = do
 654   hPutStr stdout "Writing new package config file... "
 655   old_details <- readIORef package_details
 656   h <- openFile conf_file WriteMode
 657   hPutStr h (dumpPackages (fn old_details))
 658   hClose h
 659   hPutStrLn stdout "done."
 660
 661 savePackageConfig :: String -> IO ()
 662 savePackageConfig conf_file = do
 663   hPutStr stdout "Saving old package config file... "
 664     -- mv rather than cp because we've already done an hGetContents
 665     -- on this file so we won't be able to open it for writing
 666     -- unless we move the old one out of the way...
 667   system ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old")
 668   hPutStrLn stdout "done."
 669
 670 -- package list is maintained in dependency order
 671 packages = global ["std", "rts", "gmp"] :: IORef [String]
 672 -- comma in value, so can't use macro, grrr
 673 {-# NOINLINE packages #-}
 674
 675 addPackage :: String -> IO ()
 676 addPackage package
 677   = do pkg_details <- readIORef package_details
 678        case lookup package pkg_details of
 679           Nothing -> throwDyn (OtherError ("unknown package name: " ++ package))
 680           Just details -> do
 681             ps <- readIORef packages
 682             unless (package `elem` ps) $ do
 683                 mapM_ addPackage (package_deps details)
 684                 ps <- readIORef packages
 685                 writeIORef packages (package:ps)
 686
 687 getPackageImportPath   :: IO [String]
 688 getPackageImportPath = do
 689   ps <- readIORef packages
 690   ps' <- getPackageDetails ps
 691   return (nub (concat (map import_dirs ps')))
 692
 693 getPackageIncludePath   :: IO [String]
 694 getPackageIncludePath = do
 695   ps <- readIORef packages
 696   ps' <- getPackageDetails ps
 697   return (nub (filter (not.null) (concatMap include_dirs ps')))
 698
 699         -- includes are in reverse dependency order (i.e. rts first)
 700 getPackageCIncludes   :: IO [String]
 701 getPackageCIncludes = do
 702   ps <- readIORef packages
 703   ps' <- getPackageDetails ps
 704   return (reverse (nub (filter (not.null) (concatMap c_includes ps'))))
 705
 706 getPackageLibraryPath  :: IO [String]
 707 getPackageLibraryPath = do
 708   ps <- readIORef packages
 709   ps' <- getPackageDetails ps
 710   return (nub (concat (map library_dirs ps')))
 711
 712 getPackageLibraries    :: IO [String]
 713 getPackageLibraries = do
 714   ps <- readIORef packages
 715   ps' <- getPackageDetails ps
 716   tag <- readIORef build_tag
 717   let suffix = if null tag then "" else '_':tag
 718   return (concat (
 719         map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps'
 720      ))
 721
 722 getPackageExtraGhcOpts :: IO [String]
 723 getPackageExtraGhcOpts = do
 724   ps <- readIORef packages
 725   ps' <- getPackageDetails ps
 726   return (concatMap extra_ghc_opts ps')
 727
 728 getPackageExtraCcOpts  :: IO [String]
 729 getPackageExtraCcOpts = do
 730   ps <- readIORef packages
 731   ps' <- getPackageDetails ps
 732   return (concatMap extra_cc_opts ps')
 733
 734 getPackageExtraLdOpts  :: IO [String]
 735 getPackageExtraLdOpts = do
 736   ps <- readIORef packages
 737   ps' <- getPackageDetails ps
 738   return (concatMap extra_ld_opts ps')
 739
 740 getPackageDetails :: [String] -> IO [Package]
 741 getPackageDetails ps = do
 742   pkg_details <- readIORef package_details
 743   return [ pkg | p <- ps, Just pkg <- [ lookup p pkg_details ] ]
 744
 745 GLOBAL_VAR(package_details, (error "package_details"), [(String,Package)])
 746
 747 -----------------------------------------------------------------------------
 748 -- Ways
 749
 750 -- The central concept of a "way" is that all objects in a given
 751 -- program must be compiled in the same "way".  Certain options change
 752 -- parameters of the virtual machine, eg. profiling adds an extra word
 753 -- to the object header, so profiling objects cannot be linked with
 754 -- non-profiling objects.
 755
 756 -- After parsing the command-line options, we determine which "way" we
 757 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
 758
 759 -- We then find the "build-tag" associated with this way, and this
 760 -- becomes the suffix used to find .hi files and libraries used in
 761 -- this compilation.
 762
 763 GLOBAL_VAR(build_tag, "", String)
 764
 765 data WayName
 766   = WayProf
 767   | WayUnreg
 768   | WayDll
 769   | WayTicky
 770   | WayPar
 771   | WayGran
 772   | WaySMP
 773   | WayDebug
 774   | WayUser_a
 775   | WayUser_b
 776   | WayUser_c
 777   | WayUser_d
 778   | WayUser_e
 779   | WayUser_f
 780   | WayUser_g
 781   | WayUser_h
 782   | WayUser_i
 783   | WayUser_j
 784   | WayUser_k
 785   | WayUser_l
 786   | WayUser_m
 787   | WayUser_n
 788   | WayUser_o
 789   | WayUser_A
 790   | WayUser_B
 791   deriving (Eq,Ord)
 792
 793 GLOBAL_VAR(ways, [] ,[WayName])
 794
 795 -- ToDo: allow WayDll with any other allowed combination
 796
 797 allowed_combinations =
 798    [  [WayProf,WayUnreg],
 799       [WayProf,WaySMP]     -- works???
 800    ]
 801
 802 findBuildTag :: IO [String]  -- new options
 803 findBuildTag = do
 804   way_names <- readIORef ways
 805   case sort way_names of
 806      []  -> do  writeIORef build_tag ""
 807                 return []
 808
 809      [w] -> do let details = lkupWay w
 810                writeIORef build_tag (wayTag details)
 811                return (wayOpts details)
 812
 813      ws  -> if  ws `notElem` allowed_combinations
 814                 then throwDyn (OtherError $
 815                                 "combination not supported: "  ++
 816                                 foldr1 (\a b -> a ++ '/':b)
 817                                 (map (wayName . lkupWay) ws))
 818                 else let stuff = map lkupWay ws
 819                          tag   = concat (map wayTag stuff)
 820                          flags = map wayOpts stuff
 821                      in do
 822                      writeIORef build_tag tag
 823                      return (concat flags)
 824
 825 lkupWay w =
 826    case lookup w way_details of
 827         Nothing -> error "findBuildTag"
 828         Just details -> details
 829
 830 data Way = Way {
 831   wayTag   :: String,
 832   wayName  :: String,
 833   wayOpts  :: [String]
 834   }
 835
 836 way_details :: [ (WayName, Way) ]
 837 way_details =
 838   [ (WayProf, Way  "p" "Profiling"
 839         [ "-fscc-profiling"
 840         , "-DPROFILING"
 841         , "-optc-DPROFILING"
 842         , "-fvia-C" ]),
 843
 844     (WayTicky, Way  "t" "Ticky-ticky Profiling"
 845         [ "-fticky-ticky"
 846         , "-DTICKY_TICKY"
 847         , "-optc-DTICKY_TICKY"
 848         , "-fvia-C" ]),
 849
 850     (WayUnreg, Way  "u" "Unregisterised"
 851         [ "-optc-DNO_REGS"
 852         , "-optc-DUSE_MINIINTERPRETER"
 853         , "-fno-asm-mangling"
 854         , "-funregisterised"
 855         , "-fvia-C" ]),
 856
 857     (WayDll, Way  "dll" "DLLized"
 858         [ ]),
 859
 860     (WayPar, Way  "mp" "Parallel"
 861         [ "-fstack-check"
 862         , "-fparallel"
 863         , "-D__PARALLEL_HASKELL__"
 864         , "-optc-DPAR"
 865         , "-package concurrent"
 866         , "-fvia-C" ]),
 867
 868     (WayGran, Way  "mg" "Gransim"
 869         [ "-fstack-check"
 870         , "-fgransim"
 871         , "-D__GRANSIM__"
 872         , "-optc-DGRAN"
 873         , "-package concurrent"
 874         , "-fvia-C" ]),
 875
 876     (WaySMP, Way  "s" "SMP"
 877         [ "-fsmp"
 878         , "-optc-pthread"
 879         , "-optl-pthread"
 880         , "-optc-DSMP"
 881         , "-fvia-C" ]),
 882
 883     (WayUser_a,  Way  "a"  "User way 'a'"  ["$WAY_a_REAL_OPTS"]),
 884     (WayUser_b,  Way  "b"  "User way 'b'"  ["$WAY_b_REAL_OPTS"]),
 885     (WayUser_c,  Way  "c"  "User way 'c'"  ["$WAY_c_REAL_OPTS"]),
 886     (WayUser_d,  Way  "d"  "User way 'd'"  ["$WAY_d_REAL_OPTS"]),
 887     (WayUser_e,  Way  "e"  "User way 'e'"  ["$WAY_e_REAL_OPTS"]),
 888     (WayUser_f,  Way  "f"  "User way 'f'"  ["$WAY_f_REAL_OPTS"]),
 889     (WayUser_g,  Way  "g"  "User way 'g'"  ["$WAY_g_REAL_OPTS"]),
 890     (WayUser_h,  Way  "h"  "User way 'h'"  ["$WAY_h_REAL_OPTS"]),
 891     (WayUser_i,  Way  "i"  "User way 'i'"  ["$WAY_i_REAL_OPTS"]),
 892     (WayUser_j,  Way  "j"  "User way 'j'"  ["$WAY_j_REAL_OPTS"]),
 893     (WayUser_k,  Way  "k"  "User way 'k'"  ["$WAY_k_REAL_OPTS"]),
 894     (WayUser_l,  Way  "l"  "User way 'l'"  ["$WAY_l_REAL_OPTS"]),
 895     (WayUser_m,  Way  "m"  "User way 'm'"  ["$WAY_m_REAL_OPTS"]),
 896     (WayUser_n,  Way  "n"  "User way 'n'"  ["$WAY_n_REAL_OPTS"]),
 897     (WayUser_o,  Way  "o"  "User way 'o'"  ["$WAY_o_REAL_OPTS"]),
 898     (WayUser_A,  Way  "A"  "User way 'A'"  ["$WAY_A_REAL_OPTS"]),
 899     (WayUser_B,  Way  "B"  "User way 'B'"  ["$WAY_B_REAL_OPTS"])
 900   ]
 901
 902 -----------------------------------------------------------------------------
 903 -- Programs for particular phases
 904
 905 GLOBAL_VAR(pgm_L,   findFile "unlit"      cGHC_UNLIT,      String)
 906 GLOBAL_VAR(pgm_P,   cRAWCPP,                               String)
 907 GLOBAL_VAR(pgm_C,   findFile "hsc"        cGHC_HSC,        String)
 908 GLOBAL_VAR(pgm_c,   cGCC,                                  String)
 909 GLOBAL_VAR(pgm_m,   findFile "ghc-asm"    cGHC_MANGLER,    String)
 910 GLOBAL_VAR(pgm_s,   findFile "ghc-split"  cGHC_SPLIT,      String)
 911 GLOBAL_VAR(pgm_a,   cGCC,                                  String)
 912 GLOBAL_VAR(pgm_l,   cGCC,                                  String)
 913
 914 -----------------------------------------------------------------------------
 915 -- Via-C compilation stuff
 916
 917 -- flags returned are: ( all C compilations
 918 --                     , registerised HC compilations
 919 --                     )
 920
 921 machdepCCOpts
 922    | prefixMatch "alpha"   cTARGETPLATFORM
 923         = return ( ["-static"], [] )
 924
 925    | prefixMatch "hppa"    cTARGETPLATFORM
 926         -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
 927         -- (very nice, but too bad the HP /usr/include files don't agree.)
 928         = return ( ["-static", "-D_HPUX_SOURCE"], [] )
 929
 930    | prefixMatch "m68k"    cTARGETPLATFORM
 931       -- -fno-defer-pop : for the .hc files, we want all the pushing/
 932       --    popping of args to routines to be explicit; if we let things
 933       --    be deferred 'til after an STGJUMP, imminent death is certain!
 934       --
 935       -- -fomit-frame-pointer : *don't*
 936       --     It's better to have a6 completely tied up being a frame pointer
 937       --     rather than let GCC pick random things to do with it.
 938       --     (If we want to steal a6, then we would try to do things
 939       --     as on iX86, where we *do* steal the frame pointer [%ebp].)
 940         = return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
 941
 942    | prefixMatch "i386"    cTARGETPLATFORM
 943       -- -fno-defer-pop : basically the same game as for m68k
 944       --
 945       -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
 946       --   the fp (%ebp) for our register maps.
 947         = do n_regs <- readState stolen_x86_regs
 948              sta    <- readIORef static
 949              return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" ],
 950                       [ "-fno-defer-pop", "-fomit-frame-pointer",
 951                         "-DSTOLEN_X86_REGS="++show n_regs ]
 952                     )
 953
 954    | prefixMatch "mips"    cTARGETPLATFORM
 955         = return ( ["static"], [] )
 956
 957    | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
 958         = return ( ["static"], ["-finhibit-size-directive"] )
 959
 960    | otherwise
 961         = return ( [], [] )
 962
 963 -----------------------------------------------------------------------------
 964 -- Build the Hsc command line
 965
 966 build_hsc_opts :: IO [String]
 967 build_hsc_opts = do
 968   opt_C_ <- getOpts opt_C               -- misc hsc opts
 969
 970         -- warnings
 971   warn_level <- readState warning_opt
 972   let warn_opts =  case warn_level of
 973                         W_default -> standardWarnings
 974                         W_        -> minusWOpts
 975                         W_all     -> minusWallOpts
 976                         W_not     -> []
 977
 978         -- optimisation
 979   minus_o <- readIORef opt_level
 980   optimisation_opts <-
 981         case minus_o of
 982             0 -> hsc_minusNoO_flags
 983             1 -> hsc_minusO_flags
 984             2 -> hsc_minusO2_flags
 985             _ -> error "unknown opt level"
 986             -- ToDo: -Ofile
 987
 988         -- STG passes
 989   ways_ <- readIORef ways
 990   let stg_massage | WayProf `elem` ways_ =  "-fmassage-stg-for-profiling"
 991                   | otherwise            = ""
 992
 993   stg_stats <- readIORef opt_StgStats
 994   let stg_stats_flag | stg_stats = "-dstg-stats"
 995                      | otherwise = ""
 996
 997   let stg_opts = [ stg_massage, stg_stats_flag, "-flet-no-escape" ]
 998         -- let-no-escape always on for now
 999
1000   verb <- is_verbose
1001   let hi_vers = "-fhi-version="++cProjectVersionInt
1002   static <- (do s <- readIORef static; if s then return "-static" else return "")
1003
1004   l <- readIORef hsc_lang
1005   let lang = case l of
1006                 HscC    -> "-olang=C"
1007                 HscAsm  -> "-olang=asm"
1008                 HscJava -> "-olang=java"
1009
1010   -- get hi-file suffix
1011   hisuf <- readIORef hi_suf
1012
1013   -- hi-suffix for packages depends on the build tag.
1014   package_hisuf <-
1015         do tag <- readIORef build_tag
1016            if null tag
1017                 then return "hi"
1018                 else return (tag ++ "_hi")
1019
1020   import_dirs <- readIORef import_paths
1021   package_import_dirs <- getPackageImportPath
1022
1023   let hi_map = "-himap=" ++
1024                 makeHiMap import_dirs hisuf
1025                          package_import_dirs package_hisuf
1026                          split_marker
1027
1028       hi_map_sep = "-himap-sep=" ++ [split_marker]
1029
1030   scale <- readIORef scale_sizes_by
1031   heap  <- readState specific_heap_size
1032   stack <- readState specific_stack_size
1033   cmdline_rts_opts <- getOpts opt_Crts
1034   let heap'  = truncate (fromIntegral heap  * scale) :: Integer
1035       stack' = truncate (fromIntegral stack * scale) :: Integer
1036       rts_opts = [ "+RTS", "-H"++show heap', "-K"++show stack' ]
1037                  ++ cmdline_rts_opts ++ [ "-RTS" ]
1038
1039   -- take into account -fno-* flags by removing the equivalent -f*
1040   -- flag from our list.
1041   anti_flags <- getOpts anti_opt_C
1042   let basic_opts = opt_C_ ++ warn_opts ++ optimisation_opts ++ stg_opts
1043       filtered_opts = filter (`notElem` anti_flags) basic_opts
1044
1045   return
1046         (
1047         filtered_opts
1048         -- ToDo: C stub files
1049         ++ [ hi_vers, static, verb, lang, hi_map, hi_map_sep ]
1050         ++ rts_opts
1051         )
1052
1053 makeHiMap
1054   (import_dirs         :: [String])
1055   (hi_suffix           :: String)
1056   (package_import_dirs :: [String])
1057   (package_hi_suffix   :: String)
1058   (split_marker        :: Char)
1059   = foldr (add_dir hi_suffix)
1060         (foldr (add_dir package_hi_suffix) "" package_import_dirs)
1061         import_dirs
1062   where
1063      add_dir hisuf dir str = dir ++ "%." ++ hisuf ++ split_marker : str
1064
1065
1066 getOptionsFromSource
1067         :: String               -- input file
1068         -> IO [String]          -- options, if any
1069 getOptionsFromSource file
1070   = do h <- openFile file ReadMode
1071        catchIO justIoErrors (look h)
1072           (\e -> if isEOFError e then return [] else ioError e)
1073   where
1074         look h = do
1075             l <- hGetLine h
1076             case () of
1077                 () | null l -> look h
1078                    | prefixMatch "#" l -> look h
1079                    | prefixMatch "{-# LINE" l -> look h
1080                    | Just (opts:_) <- matchRegex optionRegex l
1081                         -> return (words opts)
1082                    | otherwise -> return []
1083
1084 optionRegex = mkRegex "{-#[ \t]+OPTIONS[ \t]+(.*)#-}"
1085
1086 -----------------------------------------------------------------------------
1087 -- Main loop
1088
1089 get_source_files :: [String] -> ([String],[String])
1090 get_source_files = partition (('-' /=) . head)
1091
1092 main =
1093   -- all error messages are propagated as exceptions
1094   my_catchDyn (\dyn -> case dyn of
1095                           PhaseFailed _phase code -> exitWith code
1096                           Interrupted -> exitWith (ExitFailure 1)
1097                           _ -> do hPutStrLn stderr (show (dyn :: BarfKind))
1098                                   exitWith (ExitFailure 1)
1099               ) $
1100
1101   later cleanTempFiles $
1102         -- exceptions will be blocked while we clean the temporary files,
1103         -- so there shouldn't be any difficulty if we receive further
1104         -- signals.
1105
1106   do
1107         -- install signal handlers
1108    main_thread <- myThreadId
1109
1110 #ifndef mingw32_TARGET_OS
1111    let sig_handler = Catch (raiseInThread main_thread
1112                                 (DynException (toDyn Interrupted)))
1113    installHandler sigQUIT sig_handler Nothing
1114    installHandler sigINT  sig_handler Nothing
1115 #endif
1116
1117    pgm    <- getProgName
1118    writeIORef prog_name pgm
1119
1120    argv   <- getArgs
1121
1122         -- grab any -B options from the command line first
1123    argv'  <- setTopDir argv
1124
1125         -- read the package configuration
1126    conf_file <- readIORef package_config
1127    contents <- readFile conf_file
1128    writeIORef package_details (read contents)
1129
1130         -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
1131    (flags2, todo, stop_flag) <- getToDo argv'
1132
1133         -- process all the other arguments, and get the source files
1134    srcs <- processArgs driver_opts flags2 []
1135
1136         -- find the build tag, and re-process the build-specific options
1137    more_opts <- findBuildTag
1138    _ <- processArgs driver_opts more_opts []
1139
1140         -- get the -v flag
1141    verb <- readIORef verbose
1142
1143    when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))
1144
1145         -- mkdependHS is special
1146    when (todo == DoMkDependHS) beginMkDependHS
1147
1148         -- for each source file, find which phases to run
1149    pipelines <- mapM (genPipeline todo stop_flag) srcs
1150    let src_pipelines = zip srcs pipelines
1151
1152    o_file <- readIORef output_file
1153    if isJust o_file && todo /= DoLink && length srcs > 1
1154         then throwDyn (UsageError "can't apply -o option to multiple source files")
1155         else do
1156
1157    if null srcs then throwDyn (UsageError "no input files") else do
1158
1159         -- save the flag state, because this could be modified by OPTIONS pragmas
1160         -- during the compilation, and we'll need to restore it before starting
1161         -- the next compilation.
1162    saved_driver_state <- readIORef driver_state
1163
1164    let compileFile (src, phases) = do
1165           r <- run_pipeline phases src (todo==DoLink) True orig_base orig_suff
1166           writeIORef driver_state saved_driver_state
1167           return r
1168           where (orig_base, orig_suff) = splitFilename src
1169
1170    o_files <- mapM compileFile src_pipelines
1171
1172    when (todo == DoMkDependHS) endMkDependHS
1173
1174    when (todo == DoLink) (do_link o_files)
1175
1176
1177 -----------------------------------------------------------------------------
1178 -- Which phase to stop at
1179
1180 data ToDo = DoMkDependHS | DoMkDLL | StopBefore Phase | DoLink
1181   deriving (Eq)
1182
1183 todoFlag :: String -> Maybe ToDo
1184 todoFlag "-M" = Just $ DoMkDependHS
1185 todoFlag "-E" = Just $ StopBefore Hsc
1186 todoFlag "-C" = Just $ StopBefore HCc
1187 todoFlag "-S" = Just $ StopBefore As
1188 todoFlag "-c" = Just $ StopBefore Ln
1189 todoFlag _    = Nothing
1190
1191 getToDo :: [String]
1192          -> IO ( [String]   -- rest of command line
1193                , ToDo       -- phase to stop at
1194                , String     -- "stop at" flag
1195                )
1196 getToDo flags
1197   = case my_partition todoFlag flags of
1198         ([]   , rest) -> return (rest, DoLink,  "") -- default is to do linking
1199         ([(flag,one)], rest) -> return (rest, one, flag)
1200         (_    , _   ) ->
1201           throwDyn (OtherError "only one of the flags -M, -E, -C, -S, -c is allowed")
1202
1203 -----------------------------------------------------------------------------
1204 -- genPipeline
1205 --
1206 -- Herein is all the magic about which phases to run in which order, whether
1207 -- the intermediate files should be in /tmp or in the current directory,
1208 -- what the suffix of the intermediate files should be, etc.
1209
1210 -- The following compilation pipeline algorithm is fairly hacky.  A
1211 -- better way to do this would be to express the whole comilation as a
1212 -- data flow DAG, where the nodes are the intermediate files and the
1213 -- edges are the compilation phases.  This framework would also work
1214 -- nicely if a haskell dependency generator was included in the
1215 -- driver.
1216
1217 -- It would also deal much more cleanly with compilation phases that
1218 -- generate multiple intermediates, (eg. hsc generates .hc, .hi, and
1219 -- possibly stub files), where some of the output files need to be
1220 -- processed further (eg. the stub files need to be compiled by the C
1221 -- compiler).
1222
1223 -- A cool thing to do would then be to execute the data flow graph
1224 -- concurrently, automatically taking advantage of extra processors on
1225 -- the host machine.  For example, when compiling two Haskell files
1226 -- where one depends on the other, the data flow graph would determine
1227 -- that the C compiler from the first comilation can be overlapped
1228 -- with the hsc comilation for the second file.
1229
1230 data IntermediateFileType
1231   = Temporary
1232   | Persistent
1233   deriving (Eq)
1234
1235 -- the first compilation phase for a given file is determined
1236 -- by its suffix.
1237 startPhase "lhs"   = Unlit
1238 startPhase "hs"    = Cpp
1239 startPhase "hc"    = HCc
1240 startPhase "c"     = Cc
1241 startPhase "raw_s" = Mangle
1242 startPhase "s"     = As
1243 startPhase "S"     = As
1244 startPhase "o"     = Ln
1245 startPhase _       = Ln    -- all unknown file types
1246
1247 genPipeline
1248    :: ToDo              -- when to stop
1249    -> String            -- "stop after" flag (for error messages)
1250    -> String            -- original filename
1251    -> IO [              -- list of phases to run for this file
1252              (Phase,
1253               IntermediateFileType,  -- keep the output from this phase?
1254               String)                -- output file suffix
1255          ]
1256
1257 genPipeline todo stop_flag filename
1258  = do
1259    split      <- readIORef split_object_files
1260    mangle     <- readIORef do_asm_mangling
1261    lang       <- readIORef hsc_lang
1262    keep_hc    <- readIORef keep_hc_files
1263    keep_raw_s <- readIORef keep_raw_s_files
1264    keep_s     <- readIORef keep_s_files
1265
1266    let
1267    ----------- -----  ----   ---   --   --  -  -  -
1268     start_phase = startPhase suffix
1269
1270     (_basename, suffix) = splitFilename filename
1271
1272     haskell_ish_file = suffix `elem` [ "hs", "lhs", "hc" ]
1273     c_ish_file       = suffix `elem` [ "c", "s", "S" ]  -- maybe .cc et al.??
1274
1275         -- hack for .hc files
1276     real_lang | suffix == "hc" = HscC
1277               | otherwise      = lang
1278
1279     pipeline
1280       | todo == DoMkDependHS = [ Unlit, Cpp, MkDependHS ]
1281
1282       | haskell_ish_file =
1283        case real_lang of
1284         HscC    | split && mangle -> [ Unlit, Cpp, Hsc, HCc, Mangle,
1285                                         SplitMangle, SplitAs ]
1286                 | mangle          -> [ Unlit, Cpp, Hsc, HCc, Mangle, As ]
1287                 | split           -> not_valid
1288                 | otherwise       -> [ Unlit, Cpp, Hsc, HCc, As ]
1289
1290         HscAsm  | split           -> [ Unlit, Cpp, Hsc, SplitMangle, SplitAs ]
1291                 | otherwise       -> [ Unlit, Cpp, Hsc, As ]
1292
1293         HscJava | split           -> not_valid
1294                 | otherwise       -> error "not implemented: compiling via Java"
1295
1296       | c_ish_file      = [ Cc, As ]
1297
1298       | otherwise       = [ ]  -- just pass this file through to the linker
1299
1300         -- ToDo: this is somewhat cryptic
1301     not_valid = throwDyn (OtherError ("invalid option combination"))
1302    ----------- -----  ----   ---   --   --  -  -  -
1303
1304         -- this shouldn't happen.
1305    if start_phase /= Ln && start_phase `notElem` pipeline
1306         then throwDyn (OtherError ("can't find starting phase for "
1307                                     ++ filename))
1308         else do
1309
1310         -- if we can't find the phase we're supposed to stop before,
1311         -- something has gone wrong.
1312    case todo of
1313         StopBefore phase ->
1314            when (phase /= Ln
1315                  && phase `notElem` pipeline
1316                  && not (phase == As && SplitAs `elem` pipeline)) $
1317               throwDyn (OtherError
1318                 ("flag " ++ stop_flag
1319                  ++ " is incompatible with source file `" ++ filename ++ "'"))
1320         _ -> return ()
1321
1322    let
1323    ----------- -----  ----   ---   --   --  -  -  -
1324       annotatePipeline
1325          :: [Phase]             -- raw pipeline
1326          -> Phase               -- phase to stop before
1327          -> [(Phase, IntermediateFileType, String{-file extension-})]
1328       annotatePipeline []     _    = []
1329       annotatePipeline (Ln:_) _    = []
1330       annotatePipeline (phase:next_phase:ps) stop =
1331           (phase, keep_this_output, phase_input_ext next_phase)
1332              : annotatePipeline (next_phase:ps) stop
1333           where
1334                 keep_this_output
1335                      | next_phase == stop = Persistent
1336                      | otherwise =
1337                         case next_phase of
1338                              Ln -> Persistent
1339                              Mangle | keep_raw_s -> Persistent
1340                              As     | keep_s     -> Persistent
1341                              HCc    | keep_hc    -> Persistent
1342                              _other              -> Temporary
1343
1344         -- add information about output files to the pipeline
1345         -- the suffix on an output file is determined by the next phase
1346         -- in the pipeline, so we add linking to the end of the pipeline
1347         -- to force the output from the final phase to be a .o file.
1348       stop_phase = case todo of StopBefore phase -> phase
1349                                 DoLink           -> Ln
1350       annotated_pipeline = annotatePipeline (pipeline ++ [ Ln ]) stop_phase
1351
1352       phase_ne p (p1,_,_) = (p1 /= p)
1353    ----------- -----  ----   ---   --   --  -  -  -
1354
1355    return $
1356      dropWhile (phase_ne start_phase) .
1357         foldr (\p ps -> if phase_ne stop_phase p then p:ps else [])  []
1358                 $ annotated_pipeline
1359
1360
1361
1362 -- the output suffix for a given phase is uniquely determined by
1363 -- the input requirements of the next phase.
1364 phase_input_ext Unlit       = "lhs"
1365 phase_input_ext Cpp         = "lpp"
1366 phase_input_ext Hsc         = "cpp"
1367 phase_input_ext HCc         = "hc"
1368 phase_input_ext Cc          = "c"
1369 phase_input_ext Mangle      = "raw_s"
1370 phase_input_ext SplitMangle = "split_s" -- not really generated
1371 phase_input_ext As          = "s"
1372 phase_input_ext SplitAs     = "split_s" -- not really generated
1373 phase_input_ext Ln          = "o"
1374 phase_input_ext MkDependHS  = "dep"
1375
1376 run_pipeline
1377   :: [ (Phase, IntermediateFileType, String) ] -- phases to run
1378   -> String                     -- input file
1379   -> Bool                       -- doing linking afterward?
1380   -> Bool                       -- take into account -o when generating output?
1381   -> String                     -- original basename (eg. Main)
1382   -> String                     -- original suffix   (eg. hs)
1383   -> IO String                  -- return final filename
1384
1385 run_pipeline [] input_fn _ _ _ _ = return input_fn
1386 run_pipeline ((phase, keep, o_suffix):phases)
1387         input_fn do_linking use_ofile orig_basename orig_suffix
1388   = do
1389
1390      output_fn <-
1391         (if null phases && not do_linking && use_ofile
1392             then do o_file <- readIORef output_file
1393                     case o_file of
1394                         Just s  -> return s
1395                         Nothing -> do
1396                             f <- odir_ify (orig_basename ++ '.':o_suffix)
1397                             osuf_ify f
1398
1399             else if keep == Persistent
1400                         then odir_ify (orig_basename ++ '.':o_suffix)
1401                         else do filename <- newTempName o_suffix
1402                                 add files_to_clean filename
1403                                 return filename
1404         )
1405
1406      run_phase phase orig_basename orig_suffix input_fn output_fn
1407
1408         -- sadly, ghc -E is supposed to write the file to stdout.  We
1409         -- generate <file>.cpp, so we also have to cat the file here.
1410      when (null phases && phase == Cpp) $
1411         run_something "Dump pre-processed file to stdout"
1412                       ("cat " ++ output_fn)
1413
1414      run_pipeline phases output_fn do_linking use_ofile orig_basename orig_suffix
1415
1416
1417 -- find a temporary name that doesn't already exist.
1418 newTempName :: String -> IO String
1419 newTempName extn = do
1420   x <- getProcessID
1421   tmp_dir <- readIORef tmp_prefix
1422   findTempName tmp_dir x
1423   where findTempName tmp_dir x = do
1424            let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
1425            b  <- doesFileExist filename
1426            if b then findTempName tmp_dir (x+1)
1427                 else return filename
1428
1429 -------------------------------------------------------------------------------
1430 -- mkdependHS
1431
1432         -- flags
1433 GLOBAL_VAR(dep_makefile,        "Makefile", String);
1434 GLOBAL_VAR(dep_include_prelude, False, Bool);
1435 GLOBAL_VAR(dep_ignore_dirs,     [], [String]);
1436 GLOBAL_VAR(dep_suffixes,        [], [String]);
1437 GLOBAL_VAR(dep_warnings,        True, Bool);
1438
1439         -- global vars
1440 GLOBAL_VAR(dep_makefile_hdl,    error "dep_makefile_hdl", Maybe Handle);
1441 GLOBAL_VAR(dep_tmp_file,        error "dep_tmp_file", String);
1442 GLOBAL_VAR(dep_tmp_hdl,         error "dep_tmp_hdl", Handle);
1443 GLOBAL_VAR(dep_dir_contents,    error "dep_dir_contents", [(String,[String])]);
1444
1445 depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
1446 depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"
1447
1448 -- for compatibility with the old mkDependHS, we accept options of the form
1449 -- -optdep-f -optdep.depend, etc.
1450 dep_opts = [
1451    (  "s",                      SepArg (add dep_suffixes) ),
1452    (  "f",                      SepArg (writeIORef dep_makefile) ),
1453    (  "w",                      NoArg (writeIORef dep_warnings False) ),
1454    (  "-include-prelude",       NoArg (writeIORef dep_include_prelude True) ),
1455    (  "X",                      Prefix (addToDirList dep_ignore_dirs) ),
1456    (  "-exclude-directory=",    Prefix (addToDirList dep_ignore_dirs) )
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 (StopBefore Ln) "" 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 (addToDirList import_paths) )
2143   ,  ( "I"              , Prefix    (addToDirList include_paths) )
2144
2145         ------- Libraries ---------------------------------------------------
2146   ,  ( "L"              , Prefix (addToDirList 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