ghc/driver/Main.hs

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