ghc/driver/Main.hs

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