ghc/driver/Main.hs

   1 {-# OPTIONS -W #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: Main.hs,v 1.54 2000/08/18 04:04:48 qrczak 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        catchJust ioErrors (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                                 DoMkDependHS     -> Ln
1350                                 DoLink           -> Ln
1351       annotated_pipeline = annotatePipeline (pipeline ++ [ Ln ]) stop_phase
1352
1353       phase_ne p (p1,_,_) = (p1 /= p)
1354    ----------- -----  ----   ---   --   --  -  -  -
1355
1356    return $
1357      dropWhile (phase_ne start_phase) .
1358         foldr (\p ps -> if phase_ne stop_phase p then p:ps else [])  []
1359                 $ annotated_pipeline
1360
1361
1362
1363 -- the output suffix for a given phase is uniquely determined by
1364 -- the input requirements of the next phase.
1365 phase_input_ext Unlit       = "lhs"
1366 phase_input_ext Cpp         = "lpp"
1367 phase_input_ext Hsc         = "cpp"
1368 phase_input_ext HCc         = "hc"
1369 phase_input_ext Cc          = "c"
1370 phase_input_ext Mangle      = "raw_s"
1371 phase_input_ext SplitMangle = "split_s" -- not really generated
1372 phase_input_ext As          = "s"
1373 phase_input_ext SplitAs     = "split_s" -- not really generated
1374 phase_input_ext Ln          = "o"
1375 phase_input_ext MkDependHS  = "dep"
1376
1377 run_pipeline
1378   :: [ (Phase, IntermediateFileType, String) ] -- phases to run
1379   -> String                     -- input file
1380   -> Bool                       -- doing linking afterward?
1381   -> Bool                       -- take into account -o when generating output?
1382   -> String                     -- original basename (eg. Main)
1383   -> String                     -- original suffix   (eg. hs)
1384   -> IO String                  -- return final filename
1385
1386 run_pipeline [] input_fn _ _ _ _ = return input_fn
1387 run_pipeline ((phase, keep, o_suffix):phases)
1388         input_fn do_linking use_ofile orig_basename orig_suffix
1389   = do
1390
1391      output_fn <-
1392         (if null phases && not do_linking && use_ofile
1393             then do o_file <- readIORef output_file
1394                     case o_file of
1395                         Just s  -> return s
1396                         Nothing -> do
1397                             f <- odir_ify (orig_basename ++ '.':o_suffix)
1398                             osuf_ify f
1399
1400             else if keep == Persistent
1401                         then odir_ify (orig_basename ++ '.':o_suffix)
1402                         else do filename <- newTempName o_suffix
1403                                 add files_to_clean filename
1404                                 return filename
1405         )
1406
1407      run_phase phase orig_basename orig_suffix input_fn output_fn
1408
1409         -- sadly, ghc -E is supposed to write the file to stdout.  We
1410         -- generate <file>.cpp, so we also have to cat the file here.
1411      when (null phases && phase == Cpp) $
1412         run_something "Dump pre-processed file to stdout"
1413                       ("cat " ++ output_fn)
1414
1415      run_pipeline phases output_fn do_linking use_ofile orig_basename orig_suffix
1416
1417
1418 -- find a temporary name that doesn't already exist.
1419 newTempName :: String -> IO String
1420 newTempName extn = do
1421   x <- getProcessID
1422   tmp_dir <- readIORef tmp_prefix
1423   findTempName tmp_dir x
1424   where findTempName tmp_dir x = do
1425            let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
1426            b  <- doesFileExist filename
1427            if b then findTempName tmp_dir (x+1)
1428                 else return filename
1429
1430 -------------------------------------------------------------------------------
1431 -- mkdependHS
1432
1433         -- flags
1434 GLOBAL_VAR(dep_makefile,        "Makefile", String);
1435 GLOBAL_VAR(dep_include_prelude, False, Bool);
1436 GLOBAL_VAR(dep_ignore_dirs,     [], [String]);
1437 GLOBAL_VAR(dep_suffixes,        [], [String]);
1438 GLOBAL_VAR(dep_warnings,        True, Bool);
1439
1440         -- global vars
1441 GLOBAL_VAR(dep_makefile_hdl,    error "dep_makefile_hdl", Maybe Handle);
1442 GLOBAL_VAR(dep_tmp_file,        error "dep_tmp_file", String);
1443 GLOBAL_VAR(dep_tmp_hdl,         error "dep_tmp_hdl", Handle);
1444 GLOBAL_VAR(dep_dir_contents,    error "dep_dir_contents", [(String,[String])]);
1445
1446 depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
1447 depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"
1448
1449 -- for compatibility with the old mkDependHS, we accept options of the form
1450 -- -optdep-f -optdep.depend, etc.
1451 dep_opts = [
1452    (  "s",                      SepArg (add dep_suffixes) ),
1453    (  "f",                      SepArg (writeIORef dep_makefile) ),
1454    (  "w",                      NoArg (writeIORef dep_warnings False) ),
1455    (  "-include-prelude",       NoArg (writeIORef dep_include_prelude True) ),
1456    (  "X",                      Prefix (addToDirList dep_ignore_dirs) ),
1457    (  "-exclude-directory=",    Prefix (addToDirList dep_ignore_dirs) )
1458  ]
1459
1460 beginMkDependHS :: IO ()
1461 beginMkDependHS = do
1462
1463         -- slurp in the mkdependHS-style options
1464   flags <- getOpts opt_dep
1465   _ <- processArgs dep_opts flags []
1466
1467         -- open a new temp file in which to stuff the dependency info
1468         -- as we go along.
1469   dep_file <- newTempName "dep"
1470   add files_to_clean dep_file
1471   writeIORef dep_tmp_file dep_file
1472   tmp_hdl <- openFile dep_file WriteMode
1473   writeIORef dep_tmp_hdl tmp_hdl
1474
1475         -- open the makefile
1476   makefile <- readIORef dep_makefile
1477   exists <- doesFileExist makefile
1478   if not exists
1479         then do
1480            writeIORef dep_makefile_hdl Nothing
1481            return ()
1482
1483         else do
1484            makefile_hdl <- openFile makefile ReadMode
1485            writeIORef dep_makefile_hdl (Just makefile_hdl)
1486
1487                 -- slurp through until we get the magic start string,
1488                 -- copying the contents into dep_makefile
1489            let slurp = do
1490                 l <- hGetLine makefile_hdl
1491                 if (l == depStartMarker)
1492                         then return ()
1493                         else do hPutStrLn tmp_hdl l; slurp
1494
1495                 -- slurp through until we get the magic end marker,
1496                 -- throwing away the contents
1497            let chuck = do
1498                 l <- hGetLine makefile_hdl
1499                 if (l == depEndMarker)
1500                         then return ()
1501                         else chuck
1502
1503            catchJust ioErrors slurp
1504                 (\e -> if isEOFError e then return () else ioError e)
1505            catchJust ioErrors chuck
1506                 (\e -> if isEOFError e then return () else ioError e)
1507
1508
1509         -- write the magic marker into the tmp file
1510   hPutStrLn tmp_hdl depStartMarker
1511
1512         -- cache the contents of all the import directories, for future
1513         -- reference.
1514   import_dirs <- readIORef import_paths
1515   pkg_import_dirs <- getPackageImportPath
1516   import_dir_contents <- mapM getDirectoryContents import_dirs
1517   pkg_import_dir_contents <- mapM getDirectoryContents pkg_import_dirs
1518   writeIORef dep_dir_contents
1519         (zip import_dirs import_dir_contents ++
1520          zip pkg_import_dirs pkg_import_dir_contents)
1521
1522         -- ignore packages unless --include-prelude is on
1523   include_prelude <- readIORef dep_include_prelude
1524   when (not include_prelude) $
1525     mapM_ (add dep_ignore_dirs) pkg_import_dirs
1526
1527   return ()
1528
1529
1530 endMkDependHS :: IO ()
1531 endMkDependHS = do
1532   makefile     <- readIORef dep_makefile
1533   makefile_hdl <- readIORef dep_makefile_hdl
1534   tmp_file     <- readIORef dep_tmp_file
1535   tmp_hdl      <- readIORef dep_tmp_hdl
1536
1537         -- write the magic marker into the tmp file
1538   hPutStrLn tmp_hdl depEndMarker
1539
1540   case makefile_hdl of
1541      Nothing  -> return ()
1542      Just hdl -> do
1543
1544           -- slurp the rest of the orignal makefile and copy it into the output
1545         let slurp = do
1546                 l <- hGetLine hdl
1547                 hPutStrLn tmp_hdl l
1548                 slurp
1549
1550         catchJust ioErrors slurp
1551                 (\e -> if isEOFError e then return () else ioError e)
1552
1553         hClose hdl
1554
1555   hClose tmp_hdl  -- make sure it's flushed
1556
1557         -- create a backup of the original makefile
1558   when (isJust makefile_hdl) $
1559      run_something ("Backing up " ++ makefile)
1560         (unwords [ "cp", makefile, makefile++".bak" ])
1561
1562         -- copy the new makefile in place
1563   run_something "Installing new makefile"
1564         (unwords [ "cp", tmp_file, makefile ])
1565
1566
1567 findDependency :: String -> Import -> IO (Maybe (String, Bool))
1568 findDependency mod imp = do
1569    dir_contents <- readIORef dep_dir_contents
1570    ignore_dirs  <- readIORef dep_ignore_dirs
1571    hisuf <- readIORef hi_suf
1572
1573    let
1574      (imp_mod, is_source) =
1575         case imp of
1576            Normal str -> (str, False)
1577            Source str -> (str, True )
1578
1579      imp_hi = imp_mod ++ '.':hisuf
1580      imp_hiboot = imp_mod ++ ".hi-boot"
1581      imp_hiboot_v = imp_mod ++ ".hi-boot-" ++ cHscIfaceFileVersion
1582      imp_hs = imp_mod ++ ".hs"
1583      imp_lhs = imp_mod ++ ".lhs"
1584
1585      deps | is_source = [ imp_hiboot_v, imp_hiboot, imp_hs, imp_lhs ]
1586           | otherwise = [ imp_hi, imp_hs, imp_lhs ]
1587
1588      search [] = throwDyn (OtherError ("can't find one of the following: " ++
1589                                       unwords (map (\d -> '`': d ++ "'") deps) ++
1590                                       " (imported from `" ++ mod ++ "')"))
1591      search ((dir, contents) : dirs)
1592            | null present = search dirs
1593            | otherwise =
1594                 if dir `elem` ignore_dirs
1595                         then return Nothing
1596                         else if is_source
1597                                 then if dep /= imp_hiboot_v
1598                                         then return (Just (dir++'/':imp_hiboot, False))
1599                                         else return (Just (dir++'/':dep, False))
1600                                 else return (Just (dir++'/':imp_hi, not is_source))
1601            where
1602                 present = filter (`elem` contents) deps
1603                 dep     = head present
1604
1605    -- in
1606    search dir_contents
1607
1608
1609 -------------------------------------------------------------------------------
1610 -- Unlit phase
1611
1612 run_phase Unlit _basename _suff input_fn output_fn
1613   = do unlit <- readIORef pgm_L
1614        unlit_flags <- getOpts opt_L
1615        run_something "Literate pre-processor"
1616           ("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
1617            ++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
1618
1619 -------------------------------------------------------------------------------
1620 -- Cpp phase
1621
1622 run_phase Cpp _basename _suff input_fn output_fn
1623   = do src_opts <- getOptionsFromSource input_fn
1624         -- ToDo: this is *wrong* if we're processing more than one file:
1625         -- the OPTIONS will persist through the subsequent compilations.
1626        _ <- processArgs driver_opts src_opts []
1627
1628        do_cpp <- readState cpp_flag
1629        if do_cpp
1630           then do
1631             cpp <- readIORef pgm_P
1632             hscpp_opts <- getOpts opt_P
1633             hs_src_cpp_opts <- readIORef hs_source_cpp_opts
1634
1635             cmdline_include_paths <- readIORef include_paths
1636             pkg_include_dirs <- getPackageIncludePath
1637             let include_paths = map (\p -> "-I"++p) (cmdline_include_paths
1638                                                         ++ pkg_include_dirs)
1639
1640             verb <- is_verbose
1641             run_something "C pre-processor"
1642                 (unwords
1643                    (["echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}'", ">", output_fn, "&&",
1644                      cpp, verb]
1645                     ++ include_paths
1646                     ++ hs_src_cpp_opts
1647                     ++ hscpp_opts
1648                     ++ [ "-x", "c", input_fn, ">>", output_fn ]
1649                    ))
1650           else do
1651             run_something "Inefective C pre-processor"
1652                    ("echo '{-# LINE 1 \""  ++ input_fn ++ "\" -}' > "
1653                     ++ output_fn ++ " && cat " ++ input_fn
1654                     ++ " >> " ++ output_fn)
1655
1656 -----------------------------------------------------------------------------
1657 -- MkDependHS phase
1658
1659 run_phase MkDependHS basename suff input_fn _output_fn = do
1660    src <- readFile input_fn
1661    let imports = getImports src
1662
1663    deps <- mapM (findDependency basename) imports
1664
1665    osuf_opt <- readIORef output_suf
1666    let osuf = case osuf_opt of
1667                         Nothing -> "o"
1668                         Just s  -> s
1669
1670    extra_suffixes <- readIORef dep_suffixes
1671    let suffixes = osuf : map (++ ('_':osuf)) extra_suffixes
1672        ofiles = map (\suf -> basename ++ '.':suf) suffixes
1673
1674    objs <- mapM odir_ify ofiles
1675
1676    hdl <- readIORef dep_tmp_hdl
1677
1678         -- std dependeny of the object(s) on the source file
1679    hPutStrLn hdl (unwords objs ++ " : " ++ basename ++ '.':suff)
1680
1681    let genDep (dep, False {- not an hi file -}) =
1682           hPutStrLn hdl (unwords objs ++ " : " ++ dep)
1683        genDep (dep, True  {- is an hi file -}) = do
1684           hisuf <- readIORef hi_suf
1685           let dep_base = remove_suffix '.' dep
1686               deps = (dep_base ++ hisuf)
1687                      : map (\suf -> dep_base ++ suf ++ '_':hisuf) extra_suffixes
1688                   -- length objs should be == length deps
1689           sequence_ (zipWith (\o d -> hPutStrLn hdl (o ++ " : " ++ d)) objs deps)
1690
1691    mapM genDep [ d | Just d <- deps ]
1692
1693    return ()
1694
1695 -- add the lines to dep_makefile:
1696            -- always:
1697                    -- this.o : this.hs
1698
1699            -- if the dependency is on something other than a .hi file:
1700                    -- this.o this.p_o ... : dep
1701            -- otherwise
1702                    -- if the import is {-# SOURCE #-}
1703                            -- this.o this.p_o ... : dep.hi-boot[-$vers]
1704
1705                    -- else
1706                            -- this.o ...   : dep.hi
1707                            -- this.p_o ... : dep.p_hi
1708                            -- ...
1709
1710            -- (where .o is $osuf, and the other suffixes come from
1711            -- the cmdline -s options).
1712
1713 -----------------------------------------------------------------------------
1714 -- Hsc phase
1715
1716 run_phase Hsc   basename _suff input_fn output_fn
1717   = do  hsc <- readIORef pgm_C
1718
1719   -- we add the current directory (i.e. the directory in which
1720   -- the .hs files resides) to the import path, since this is
1721   -- what gcc does, and it's probably what you want.
1722         let current_dir = getdir basename
1723
1724         paths <- readIORef include_paths
1725         writeIORef include_paths (current_dir : paths)
1726
1727   -- build the hsc command line
1728         hsc_opts <- build_hsc_opts
1729
1730         doing_hi <- readIORef produceHi
1731         tmp_hi_file <- if doing_hi
1732                           then do fn <- newTempName "hi"
1733                                   add files_to_clean fn
1734                                   return fn
1735                           else return ""
1736
1737   -- deal with -Rghc-timing
1738         timing <- readIORef collect_ghc_timing
1739         stat_file <- newTempName "stat"
1740         add files_to_clean stat_file
1741         let stat_opts | timing    = [ "+RTS", "-S"++stat_file, "-RTS" ]
1742                       | otherwise = []
1743
1744   -- tmp files for foreign export stub code
1745         tmp_stub_h <- newTempName "stub_h"
1746         tmp_stub_c <- newTempName "stub_c"
1747         add files_to_clean tmp_stub_h
1748         add files_to_clean tmp_stub_c
1749
1750   -- figure out where to put the .hi file
1751         ohi    <- readIORef output_hi
1752         hisuf  <- readIORef hi_suf
1753         let hi_flags = case ohi of
1754                            Nothing -> [ "-hidir="++current_dir, "-hisuf="++hisuf ]
1755                            Just fn -> [ "-hifile="++fn ]
1756
1757   -- run the compiler!
1758         run_something "Haskell Compiler"
1759                  (unwords (hsc : input_fn : (
1760                     hsc_opts
1761                     ++ hi_flags
1762                     ++ [
1763                           "-ofile="++output_fn,
1764                           "-F="++tmp_stub_c,
1765                           "-FH="++tmp_stub_h
1766                        ]
1767                     ++ stat_opts
1768                  )))
1769
1770   -- Generate -Rghc-timing info
1771         when (timing) (
1772             run_something "Generate timing stats"
1773                 (findFile "ghc-stats" cGHC_STATS ++ ' ':stat_file)
1774          )
1775
1776   -- Deal with stubs
1777         let stub_h = basename ++ "_stub.h"
1778         let stub_c = basename ++ "_stub.c"
1779
1780                 -- copy .h_stub file into current dir if present
1781         b <- doesFileExist tmp_stub_h
1782         when b (do
1783                 run_something "Copy stub .h file"
1784                                 ("cp " ++ tmp_stub_h ++ ' ':stub_h)
1785
1786                         -- #include <..._stub.h> in .hc file
1787                 addCmdlineHCInclude tmp_stub_h  -- hack
1788
1789                         -- copy the _stub.c file into the current dir
1790                 run_something "Copy stub .c file"
1791                     (unwords [
1792                         "rm -f", stub_c, "&&",
1793                         "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
1794                         "cat", tmp_stub_c, ">> ", stub_c
1795                         ])
1796
1797                         -- compile the _stub.c file w/ gcc
1798                 pipeline <- genPipeline (StopBefore Ln) "" stub_c
1799                 run_pipeline pipeline stub_c False{-no linking-}
1800                                 False{-no -o option-}
1801                                 (basename++"_stub") "c"
1802
1803                 add ld_inputs (basename++"_stub.o")
1804          )
1805
1806 -----------------------------------------------------------------------------
1807 -- Cc phase
1808
1809 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
1810 -- way too many hacks, and I can't say I've ever used it anyway.
1811
1812 run_phase cc_phase _basename _suff input_fn output_fn
1813    | cc_phase == Cc || cc_phase == HCc
1814    = do cc <- readIORef pgm_c
1815         cc_opts <- (getOpts opt_c)
1816         cmdline_include_dirs <- readIORef include_paths
1817
1818         let hcc = cc_phase == HCc
1819
1820                 -- add package include paths even if we're just compiling
1821                 -- .c files; this is the Value Add(TM) that using
1822                 -- ghc instead of gcc gives you :)
1823         pkg_include_dirs <- getPackageIncludePath
1824         let include_paths = map (\p -> "-I"++p) (cmdline_include_dirs
1825                                                         ++ pkg_include_dirs)
1826
1827         c_includes <- getPackageCIncludes
1828         cmdline_includes <- readState cmdline_hc_includes -- -#include options
1829
1830         let cc_injects | hcc = unlines (map mk_include
1831                                         (reverse cmdline_includes ++ c_includes))
1832                        | otherwise = ""
1833             mk_include h_file =
1834                 case h_file of
1835                    '"':_{-"-} -> "#include "++h_file
1836                    '<':_      -> "#include "++h_file
1837                    _          -> "#include \""++h_file++"\""
1838
1839         cc_help <- newTempName "c"
1840         add files_to_clean cc_help
1841         h <- openFile cc_help WriteMode
1842         hPutStr h cc_injects
1843         hPutStrLn h ("#include \"" ++ input_fn ++ "\"\n")
1844         hClose h
1845
1846         ccout <- newTempName "ccout"
1847         add files_to_clean ccout
1848
1849         mangle <- readIORef do_asm_mangling
1850         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
1851
1852         verb <- is_verbose
1853
1854         o2 <- readIORef opt_minus_o2_for_C
1855         let opt_flag | o2        = "-O2"
1856                      | otherwise = "-O"
1857
1858         pkg_extra_cc_opts <- getPackageExtraCcOpts
1859
1860         excessPrecision <- readState excess_precision
1861
1862         run_something "C Compiler"
1863          (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
1864                    ++ md_c_flags
1865                    ++ (if cc_phase == HCc && mangle
1866                          then md_regd_c_flags
1867                          else [])
1868                    ++ [ verb, "-S", "-Wimplicit", opt_flag ]
1869                    ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
1870                    ++ cc_opts
1871 #ifdef mingw32_TARGET_OS
1872                    ++ [" -mno-cygwin"]
1873 #endif
1874                    ++ (if excessPrecision then [] else [ "-ffloat-store" ])
1875                    ++ include_paths
1876                    ++ pkg_extra_cc_opts
1877 --                 ++ [">", ccout]
1878                    ))
1879
1880         -- ToDo: postprocess the output from gcc
1881
1882 -----------------------------------------------------------------------------
1883 -- Mangle phase
1884
1885 run_phase Mangle _basename _suff input_fn output_fn
1886   = do mangler <- readIORef pgm_m
1887        mangler_opts <- getOpts opt_m
1888        machdep_opts <-
1889          if (prefixMatch "i386" cTARGETPLATFORM)
1890             then do n_regs <- readState stolen_x86_regs
1891                     return [ show n_regs ]
1892             else return []
1893        run_something "Assembly Mangler"
1894         (unwords (mangler :
1895                      mangler_opts
1896                   ++ [ input_fn, output_fn ]
1897                   ++ machdep_opts
1898                 ))
1899
1900 -----------------------------------------------------------------------------
1901 -- Splitting phase
1902
1903 run_phase SplitMangle _basename _suff input_fn _output_fn
1904   = do  splitter <- readIORef pgm_s
1905
1906         -- this is the prefix used for the split .s files
1907         tmp_pfx <- readIORef tmp_prefix
1908         x <- getProcessID
1909         let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
1910         writeIORef split_prefix split_s_prefix
1911         add files_to_clean (split_s_prefix ++ "__*") -- d:-)
1912
1913         -- allocate a tmp file to put the no. of split .s files in (sigh)
1914         n_files <- newTempName "n_files"
1915         add files_to_clean n_files
1916
1917         run_something "Split Assembly File"
1918          (unwords [ splitter
1919                   , input_fn
1920                   , split_s_prefix
1921                   , n_files ]
1922          )
1923
1924         -- save the number of split files for future references
1925         s <- readFile n_files
1926         let n = read s :: Int
1927         writeIORef n_split_files n
1928
1929 -----------------------------------------------------------------------------
1930 -- As phase
1931
1932 run_phase As _basename _suff input_fn output_fn
1933   = do  as <- readIORef pgm_a
1934         as_opts <- getOpts opt_a
1935
1936         cmdline_include_paths <- readIORef include_paths
1937         let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
1938         run_something "Assembler"
1939            (unwords (as : as_opts
1940                        ++ cmdline_include_flags
1941                        ++ [ "-c", input_fn, "-o",  output_fn ]
1942                     ))
1943
1944 run_phase SplitAs basename _suff _input_fn _output_fn
1945   = do  as <- readIORef pgm_a
1946         as_opts <- getOpts opt_a
1947
1948         split_s_prefix <- readIORef split_prefix
1949         n <- readIORef n_split_files
1950
1951         odir <- readIORef output_dir
1952         let real_odir = case odir of
1953                                 Nothing -> basename
1954                                 Just d  -> d
1955
1956         let assemble_file n = do
1957                     let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
1958                     let output_o = newdir real_odir
1959                                         (basename ++ "__" ++ show n ++ ".o")
1960                     real_o <- osuf_ify output_o
1961                     run_something "Assembler"
1962                             (unwords (as : as_opts
1963                                       ++ [ "-c", "-o", real_o, input_s ]
1964                             ))
1965
1966         mapM_ assemble_file [1..n]
1967
1968 -----------------------------------------------------------------------------
1969 -- Linking
1970
1971 do_link :: [String] -> IO ()
1972 do_link o_files = do
1973     ln <- readIORef pgm_l
1974     verb <- is_verbose
1975     o_file <- readIORef output_file
1976     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1977
1978     pkg_lib_paths <- getPackageLibraryPath
1979     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1980
1981     lib_paths <- readIORef library_paths
1982     let lib_path_opts = map ("-L"++) lib_paths
1983
1984     pkg_libs <- getPackageLibraries
1985     let pkg_lib_opts = map (\lib -> "-l"++lib) pkg_libs
1986
1987     libs <- readIORef cmdline_libraries
1988     let lib_opts = map ("-l"++) (reverse libs)
1989          -- reverse because they're added in reverse order from the cmd line
1990
1991     pkg_extra_ld_opts <- getPackageExtraLdOpts
1992
1993         -- probably _stub.o files
1994     extra_ld_inputs <- readIORef ld_inputs
1995
1996         -- opts from -optl-<blah>
1997     extra_ld_opts <- getOpts opt_l
1998
1999     run_something "Linker"
2000        (unwords
2001          ([ ln, verb, "-o", output_fn ]
2002          ++ o_files
2003          ++ extra_ld_inputs
2004          ++ lib_path_opts
2005          ++ lib_opts
2006          ++ pkg_lib_path_opts
2007          ++ pkg_lib_opts
2008          ++ pkg_extra_ld_opts
2009          ++ extra_ld_opts
2010         )
2011        )
2012
2013 -----------------------------------------------------------------------------
2014 -- Running an external program
2015
2016 run_something phase_name cmd
2017  = do
2018    verb <- readIORef verbose
2019    when verb $ do
2020         putStr phase_name
2021         putStrLn ":"
2022         putStrLn cmd
2023         hFlush stdout
2024
2025    -- test for -n flag
2026    n <- readIORef dry_run
2027    unless n $ do
2028
2029    -- and run it!
2030 #ifndef mingw32_TARGET_OS
2031    exit_code <- system cmd `catchAllIO`
2032                    (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
2033 #else
2034    tmp <- newTempName "sh"
2035    h <- openFile tmp WriteMode
2036    hPutStrLn h cmd
2037    hClose h
2038    exit_code <- system ("sh - " ++ tmp) `catchAllIO`
2039                    (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
2040    removeFile tmp
2041 #endif
2042
2043    if exit_code /= ExitSuccess
2044         then throwDyn (PhaseFailed phase_name exit_code)
2045         else do when verb (putStr "\n")
2046                 return ()
2047
2048 -----------------------------------------------------------------------------
2049 -- Flags
2050
2051 data OptKind
2052         = NoArg (IO ())                 -- flag with no argument
2053         | HasArg (String -> IO ())      -- flag has an argument (maybe prefix)
2054         | SepArg (String -> IO ())      -- flag has a separate argument
2055         | Prefix (String -> IO ())      -- flag is a prefix only
2056         | OptPrefix (String -> IO ())   -- flag may be a prefix
2057         | AnySuffix (String -> IO ())   -- flag is a prefix, pass whole arg to fn
2058         | PassFlag  (String -> IO ())   -- flag with no arg, pass flag to fn
2059
2060 -- note that ordering is important in the following list: any flag which
2061 -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
2062 -- flags further down the list with the same prefix.
2063
2064 driver_opts =
2065   [  ------- help -------------------------------------------------------
2066      ( "?"              , NoArg long_usage)
2067   ,  ( "-help"          , NoArg long_usage)
2068
2069
2070       ------- version ----------------------------------------------------
2071   ,  ( "-version"        , NoArg (do hPutStrLn stdout (cProjectName
2072                                       ++ ", version " ++ version_str)
2073                                      exitWith ExitSuccess))
2074   ,  ( "-numeric-version", NoArg (do hPutStrLn stdout version_str
2075                                      exitWith ExitSuccess))
2076
2077       ------- verbosity ----------------------------------------------------
2078   ,  ( "v"              , NoArg (writeIORef verbose True) )
2079   ,  ( "n"              , NoArg (writeIORef dry_run True) )
2080
2081         ------- recompilation checker --------------------------------------
2082   ,  ( "recomp"         , NoArg (writeIORef recomp True) )
2083   ,  ( "no-recomp"      , NoArg (writeIORef recomp False) )
2084
2085         ------- ways --------------------------------------------------------
2086   ,  ( "prof"           , NoArg (addNoDups ways WayProf) )
2087   ,  ( "unreg"          , NoArg (addNoDups ways WayUnreg) )
2088   ,  ( "dll"            , NoArg (addNoDups ways WayDll) )
2089   ,  ( "ticky"          , NoArg (addNoDups ways WayTicky) )
2090   ,  ( "parallel"       , NoArg (addNoDups ways WayPar) )
2091   ,  ( "gransim"        , NoArg (addNoDups ways WayGran) )
2092   ,  ( "smp"            , NoArg (addNoDups ways WaySMP) )
2093   ,  ( "debug"          , NoArg (addNoDups ways WayDebug) )
2094         -- ToDo: user ways
2095
2096         ------- Interface files ---------------------------------------------
2097   ,  ( "hi"             , NoArg (writeIORef produceHi True) )
2098   ,  ( "nohi"           , NoArg (writeIORef produceHi False) )
2099   ,  ( "hi-diffs"       , NoArg (writeIORef hi_diffs  NormalHiDiffs) )
2100   ,  ( "no-hi-diffs"    , NoArg (writeIORef hi_diffs  NoHiDiffs) )
2101   ,  ( "hi-diffs-with-usages" , NoArg (writeIORef hi_diffs UsageHiDiffs) )
2102   ,  ( "keep-hi-diffs"  , NoArg (writeIORef keep_hi_diffs True) )
2103         --"hi-with-*"    -> hiw <- readIORef hi_with  (ToDo)
2104
2105         --------- Profiling --------------------------------------------------
2106   ,  ( "auto-dicts"     , NoArg (addOpt_C "-fauto-sccs-on-dicts") )
2107   ,  ( "auto-all"       , NoArg (addOpt_C "-fauto-sccs-on-all-toplevs") )
2108   ,  ( "auto"           , NoArg (addOpt_C "-fauto-sccs-on-exported-toplevs") )
2109   ,  ( "caf-all"        , NoArg (addOpt_C "-fauto-sccs-on-individual-cafs") )
2110          -- "ignore-sccs"  doesn't work  (ToDo)
2111
2112         ------- Miscellaneous -----------------------------------------------
2113   ,  ( "cpp"            , NoArg (updateState (\s -> s{ cpp_flag = True })) )
2114   ,  ( "#include"       , HasArg (addCmdlineHCInclude) )
2115   ,  ( "no-link-chk"    , NoArg (return ()) ) -- ignored for backwards compat
2116
2117         ------- Output Redirection ------------------------------------------
2118   ,  ( "odir"           , HasArg (writeIORef output_dir  . Just) )
2119   ,  ( "o"              , SepArg (writeIORef output_file . Just) )
2120   ,  ( "osuf"           , HasArg (writeIORef output_suf  . Just) )
2121   ,  ( "hisuf"          , HasArg (writeIORef hi_suf) )
2122   ,  ( "tmpdir"         , HasArg (writeIORef tmp_prefix  . (++ "/")) )
2123   ,  ( "ohi"            , HasArg (\s -> case s of
2124                                           "-" -> writeIORef hi_on_stdout True
2125                                           _   -> writeIORef output_hi (Just s)) )
2126         -- -odump?
2127
2128   ,  ( "keep-hc-file"   , AnySuffix (\_ -> writeIORef keep_hc_files True) )
2129   ,  ( "keep-s-file"    , AnySuffix (\_ -> writeIORef keep_s_files  True) )
2130   ,  ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef keep_raw_s_files  True) )
2131   ,  ( "keep-tmp-files" , AnySuffix (\_ -> writeIORef keep_tmp_files True) )
2132
2133   ,  ( "split-objs"     , NoArg (if can_split
2134                                     then do writeIORef split_object_files True
2135                                             addOpt_C "-fglobalise-toplev-names"
2136                                             addOpt_c "-DUSE_SPLIT_MARKERS"
2137                                     else hPutStrLn stderr
2138                                             "warning: don't know how to  split \
2139                                             \object files on this architecture"
2140                                 ) )
2141
2142         ------- Include/Import Paths ----------------------------------------
2143   ,  ( "i"              , OptPrefix (addToDirList import_paths) )
2144   ,  ( "I"              , Prefix    (addToDirList include_paths) )
2145
2146         ------- Libraries ---------------------------------------------------
2147   ,  ( "L"              , Prefix (addToDirList library_paths) )
2148   ,  ( "l"              , Prefix (add cmdline_libraries) )
2149
2150         ------- Packages ----------------------------------------------------
2151   ,  ( "package-name"   , HasArg (\s -> addOpt_C ("-inpackage="++s)) )
2152
2153   ,  ( "package"        , HasArg (addPackage) )
2154   ,  ( "syslib"         , HasArg (addPackage) ) -- for compatibility w/ old vsns
2155
2156   ,  ( "-list-packages"  , NoArg (listPackages) )
2157   ,  ( "-add-package"    , NoArg (newPackage) )
2158   ,  ( "-delete-package" , SepArg (deletePackage) )
2159
2160         ------- Specific phases  --------------------------------------------
2161   ,  ( "pgmL"           , HasArg (writeIORef pgm_L) )
2162   ,  ( "pgmP"           , HasArg (writeIORef pgm_P) )
2163   ,  ( "pgmC"           , HasArg (writeIORef pgm_C) )
2164   ,  ( "pgmc"           , HasArg (writeIORef pgm_c) )
2165   ,  ( "pgmm"           , HasArg (writeIORef pgm_m) )
2166   ,  ( "pgms"           , HasArg (writeIORef pgm_s) )
2167   ,  ( "pgma"           , HasArg (writeIORef pgm_a) )
2168   ,  ( "pgml"           , HasArg (writeIORef pgm_l) )
2169
2170   ,  ( "optdep"         , HasArg (addOpt_dep) )
2171   ,  ( "optL"           , HasArg (addOpt_L) )
2172   ,  ( "optP"           , HasArg (addOpt_P) )
2173   ,  ( "optCrts"        , HasArg (addOpt_Crts) )
2174   ,  ( "optC"           , HasArg (addOpt_C) )
2175   ,  ( "optc"           , HasArg (addOpt_c) )
2176   ,  ( "optm"           , HasArg (addOpt_m) )
2177   ,  ( "opta"           , HasArg (addOpt_a) )
2178   ,  ( "optl"           , HasArg (addOpt_l) )
2179   ,  ( "optdll"         , HasArg (addOpt_dll) )
2180
2181         ------ HsCpp opts ---------------------------------------------------
2182   ,  ( "D"              , Prefix (\s -> addOpt_P ("-D'"++s++"'") ) )
2183   ,  ( "U"              , Prefix (\s -> addOpt_P ("-U'"++s++"'") ) )
2184
2185         ------ Warning opts -------------------------------------------------
2186   ,  ( "W"              , NoArg (updateState (\s -> s{ warning_opt = W_ })))
2187   ,  ( "Wall"           , NoArg (updateState (\s -> s{ warning_opt = W_all })))
2188   ,  ( "Wnot"           , NoArg (updateState (\s -> s{ warning_opt = W_not })))
2189   ,  ( "w"              , NoArg (updateState (\s -> s{ warning_opt = W_not })))
2190
2191         ----- Linker --------------------------------------------------------
2192   ,  ( "static"         , NoArg (writeIORef static True) )
2193
2194         ------ Compiler RTS options -----------------------------------------
2195   ,  ( "H"                 , HasArg (newHeapSize  . decodeSize) )
2196   ,  ( "K"                 , HasArg (newStackSize . decodeSize) )
2197   ,  ( "Rscale-sizes"      , HasArg (floatOpt scale_sizes_by) )
2198   ,  ( "Rghc-timing"       , NoArg  (writeIORef collect_ghc_timing True) )
2199
2200         ------ Debugging ----------------------------------------------------
2201   ,  ( "dstg-stats"        , NoArg (writeIORef opt_StgStats True) )
2202
2203   ,  ( "dno-"              , Prefix (\s -> addAntiOpt_C ("-d"++s)) )
2204   ,  ( "d"                 , AnySuffix (addOpt_C) )
2205
2206         ------ Machine dependant (-m<blah>) stuff ---------------------------
2207
2208   ,  ( "monly-2-regs",          NoArg (updateState (\s -> s{stolen_x86_regs = 2}) ))
2209   ,  ( "monly-3-regs",          NoArg (updateState (\s -> s{stolen_x86_regs = 3}) ))
2210   ,  ( "monly-4-regs",          NoArg (updateState (\s -> s{stolen_x86_regs = 4}) ))
2211
2212         ------ Compiler flags -----------------------------------------------
2213   ,  ( "O2-for-C"          , NoArg (writeIORef opt_minus_o2_for_C True) )
2214   ,  ( "O"                 , OptPrefix (setOptLevel) )
2215
2216   ,  ( "fglasgow-exts-no-lang", NoArg ( do addOpt_C "-fglasgow-exts") )
2217
2218   ,  ( "fglasgow-exts"     , NoArg (do addOpt_C "-fglasgow-exts"
2219                                        addPackage "lang"))
2220
2221   ,  ( "fasm"              , OptPrefix (\_ -> writeIORef hsc_lang HscAsm) )
2222
2223   ,  ( "fvia-c"            , NoArg (writeIORef hsc_lang HscC) )
2224   ,  ( "fvia-C"            , NoArg (writeIORef hsc_lang HscC) )
2225
2226   ,  ( "fno-asm-mangling"  , NoArg (writeIORef do_asm_mangling False) )
2227
2228   ,  ( "fmax-simplifier-iterations",
2229                 Prefix (writeIORef opt_MaxSimplifierIterations . read) )
2230
2231   ,  ( "fusagesp"          , NoArg (do writeIORef opt_UsageSPInf True
2232                                        addOpt_C "-fusagesp-on") )
2233
2234   ,  ( "fexcess-precision" , NoArg (do updateState
2235                                            (\s -> s{ excess_precision = True })
2236                                        addOpt_C "-fexcess-precision"))
2237
2238         -- flags that are "active negatives"
2239   ,  ( "fno-implicit-prelude"   , PassFlag (addOpt_C) )
2240   ,  ( "fno-prune-tydecls"      , PassFlag (addOpt_C) )
2241   ,  ( "fno-prune-instdecls"    , PassFlag (addOpt_C) )
2242   ,  ( "fno-pre-inlining"       , PassFlag (addOpt_C) )
2243
2244         -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
2245   ,  ( "fno-",                  Prefix (\s -> addAntiOpt_C ("-f"++s)) )
2246
2247         -- Pass all remaining "-f<blah>" options to hsc
2248   ,  ( "f",                     AnySuffix (addOpt_C) )
2249   ]
2250
2251 -----------------------------------------------------------------------------
2252 -- Process command-line
2253
2254 processArgs :: [(String,OptKind)] -> [String] -> [String]
2255    -> IO [String]  -- returns spare args
2256 processArgs _spec [] spare = return (reverse spare)
2257 processArgs spec args@(('-':_):_) spare = do
2258   args' <- processOneArg spec args
2259   processArgs spec args' spare
2260 processArgs spec (arg:args) spare =
2261   processArgs spec args (arg:spare)
2262
2263 processOneArg :: [(String,OptKind)] -> [String] -> IO [String]
2264 processOneArg spec (('-':arg):args) = do
2265   let (rest,action) = findArg spec arg
2266       dash_arg = '-':arg
2267   case action of
2268
2269         NoArg  io ->
2270                 if rest == ""
2271                         then io >> return args
2272                         else unknownFlagErr dash_arg
2273
2274         HasArg fio ->
2275                 if rest /= ""
2276                         then fio rest >> return args
2277                         else case args of
2278                                 [] -> unknownFlagErr dash_arg
2279                                 (arg1:args1) -> fio arg1 >> return args1
2280
2281         SepArg fio ->
2282                 case args of
2283                         [] -> unknownFlagErr dash_arg
2284                         (arg1:args1) -> fio arg1 >> return args1
2285
2286         Prefix fio ->
2287                 if rest /= ""
2288                         then fio rest >> return args
2289                         else unknownFlagErr dash_arg
2290
2291         OptPrefix fio -> fio rest >> return args
2292
2293         AnySuffix fio -> fio ('-':arg) >> return args
2294
2295         PassFlag fio  ->
2296                 if rest /= ""
2297                         then unknownFlagErr dash_arg
2298                         else fio ('-':arg) >> return args
2299
2300 findArg :: [(String,OptKind)] -> String -> (String,OptKind)
2301 findArg spec arg
2302   = case [ (remove_spaces rest, k) | (pat,k) <- spec,
2303                                      Just rest <- [my_prefix_match pat arg],
2304                                      is_prefix k || null rest ] of
2305         [] -> unknownFlagErr ('-':arg)
2306         (one:_) -> one
2307
2308 is_prefix (NoArg _) = False
2309 is_prefix (SepArg _) = False
2310 is_prefix (PassFlag _) = False
2311 is_prefix _ = True
2312
2313 -----------------------------------------------------------------------------
2314 -- convert sizes like "3.5M" into integers
2315
2316 decodeSize :: String -> Integer
2317 decodeSize str
2318   | c == ""              = truncate n
2319   | c == "K" || c == "k" = truncate (n * 1000)
2320   | c == "M" || c == "m" = truncate (n * 1000 * 1000)
2321   | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
2322   | otherwise            = throwDyn (OtherError ("can't decode size: " ++ str))
2323   where (m, c) = span pred str
2324         n      = read m  :: Double
2325         pred c = isDigit c || c == '.'
2326
2327 floatOpt :: IORef Double -> String -> IO ()
2328 floatOpt ref str
2329   = writeIORef ref (read str :: Double)
2330
2331 -----------------------------------------------------------------------------
2332 -- Finding files in the installation
2333
2334 GLOBAL_VAR(topDir, clibdir, String)
2335
2336         -- grab the last -B option on the command line, and
2337         -- set topDir to its value.
2338 setTopDir :: [String] -> IO [String]
2339 setTopDir args = do
2340   let (minusbs, others) = partition (prefixMatch "-B") args
2341   (case minusbs of
2342     []   -> writeIORef topDir clibdir
2343     some -> writeIORef topDir (drop 2 (last some)))
2344   return others
2345
2346 findFile name alt_path = unsafePerformIO (do
2347   top_dir <- readIORef topDir
2348   let installed_file = top_dir ++ '/':name
2349   let inplace_file   = top_dir ++ '/':cCURRENT_DIR ++ '/':alt_path
2350   b <- doesFileExist inplace_file
2351   if b  then return inplace_file
2352         else return installed_file
2353  )
2354
2355 -----------------------------------------------------------------------------
2356 -- Utils
2357
2358 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
2359 my_partition _ [] = ([],[])
2360 my_partition p (a:as)
2361   = let (bs,cs) = my_partition p as in
2362     case p a of
2363         Nothing -> (bs,a:cs)
2364         Just b  -> ((a,b):bs,cs)
2365
2366 my_prefix_match :: String -> String -> Maybe String
2367 my_prefix_match [] rest = Just rest
2368 my_prefix_match (_:_) [] = Nothing
2369 my_prefix_match (p:pat) (r:rest)
2370   | p == r    = my_prefix_match pat rest
2371   | otherwise = Nothing
2372
2373 prefixMatch :: Eq a => [a] -> [a] -> Bool
2374 prefixMatch [] _str = True
2375 prefixMatch _pat [] = False
2376 prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
2377                           | otherwise = False
2378
2379 postfixMatch :: String -> String -> Bool
2380 postfixMatch pat str = prefixMatch (reverse pat) (reverse str)
2381
2382 later = flip finally
2383
2384 my_catchDyn = flip catchDyn
2385
2386 global :: a -> IORef a
2387 global a = unsafePerformIO (newIORef a)
2388
2389 splitFilename :: String -> (String,String)
2390 splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext)
2391   where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
2392         stripDot ('.':xs) = xs
2393         stripDot xs       = xs
2394
2395 suffixOf :: String -> String
2396 suffixOf s = drop_longest_prefix s '.'
2397
2398 split :: Char -> String -> [String]
2399 split c s = case rest of
2400                 []     -> [chunk]
2401                 _:rest -> chunk : split c rest
2402   where (chunk, rest) = break (==c) s
2403
2404 add :: IORef [a] -> a -> IO ()
2405 add var x = do
2406   xs <- readIORef var
2407   writeIORef var (x:xs)
2408
2409 addNoDups :: Eq a => IORef [a] -> a -> IO ()
2410 addNoDups var x = do
2411   xs <- readIORef var
2412   unless (x `elem` xs) $ writeIORef var (x:xs)
2413
2414 remove_suffix :: Char -> String -> String
2415 remove_suffix c s
2416   | null pre  = reverse suf
2417   | otherwise = reverse pre
2418   where (suf,pre) = break (==c) (reverse s)
2419
2420 drop_longest_prefix :: String -> Char -> String
2421 drop_longest_prefix s c = reverse suf
2422   where (suf,_pre) = break (==c) (reverse s)
2423
2424 take_longest_prefix :: String -> Char -> String
2425 take_longest_prefix s c = reverse pre
2426   where (_suf,pre) = break (==c) (reverse s)
2427
2428 newsuf :: String -> String -> String
2429 newsuf suf s = remove_suffix '.' s ++ suf
2430
2431 -- getdir strips the filename off the input string, returning the directory.
2432 getdir :: String -> String
2433 getdir s = if null dir then "." else init dir
2434   where dir = take_longest_prefix s '/'
2435
2436 newdir :: String -> String -> String
2437 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
2438
2439 remove_spaces :: String -> String
2440 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
2441
2442 -----------------------------------------------------------------------------
2443 -- compatibility code
2444
2445 #if __GLASGOW_HASKELL__ <= 408
2446 catchJust = catchIO
2447 ioErrors  = justIoErrors
2448 #endif