--- non-configured things
-
-cHaskell1Version = "5" -- i.e., Haskell 98
-
------------------------------------------------------------------------------
--- Usage Message
-
-short_usage = "Usage: For basic information, try the `--help' option."
-
-long_usage = do
- let usage_file = "ghc-usage.txt"
- usage_path = findFile usage_file (cGHC_DRIVER_DIR ++ '/':usage_file)
- usage <- readFile usage_path
- dump usage
- exitWith ExitSuccess
- where
- dump "" = return ()
- dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s
- dump (c:s) = hPutChar stderr c >> dump s
-
-version_str = cProjectVersion
-
------------------------------------------------------------------------------
--- Driver state
-
--- certain flags can be specified on a per-file basis, in an OPTIONS
--- pragma at the beginning of the source file. This means that when
--- compiling mulitple files, we have to restore the global option
--- settings before compiling a new file.
---
--- The DriverState record contains the per-file-mutable state.
-
-data DriverState = DriverState {
-
- -- are we runing cpp on this file?
- cpp_flag :: Bool,
-
- -- heap/stack sizes
- specific_heap_size :: Integer,
- specific_stack_size :: Integer,
-
- -- misc
- stolen_x86_regs :: Int,
- excess_precision :: Bool,
- warning_opt :: WarningState,
- cmdline_hc_includes :: [String],
-
- -- options for a particular phase
- anti_opt_C :: [String],
- opt_dep :: [String],
- opt_L :: [String],
- opt_P :: [String],
- opt_C :: [String],
- opt_c :: [String],
- opt_a :: [String],
- opt_m :: [String],
- opt_l :: [String],
- opt_dll :: [String]
- }
-
-initDriverState = DriverState {
- cpp_flag = False,
- specific_heap_size = 6 * 1000 * 1000,
- specific_stack_size = 1000 * 1000,
- stolen_x86_regs = 4,
- excess_precision = False,
- warning_opt = W_default,
- cmdline_hc_includes = [],
- anti_opt_C = [],
- opt_dep = [],
- opt_L = [],
- opt_P = [],
- opt_C = [],
- opt_c = [],
- opt_a = [],
- opt_m = [],
- opt_l = [],
- opt_dll = []
- }
-
-GLOBAL_VAR(driver_state, initDriverState, DriverState)
-
-readState :: (DriverState -> a) -> IO a
-readState f = readIORef driver_state >>= return . f
-
-updateState :: (DriverState -> DriverState) -> IO ()
-updateState f = readIORef driver_state >>= writeIORef driver_state . f
-
-addAntiOpt_C a = updateState (\s -> s{anti_opt_C = a : anti_opt_C s})
-addOpt_dep a = updateState (\s -> s{opt_dep = a : opt_dep s})
-addOpt_L a = updateState (\s -> s{opt_L = a : opt_L s})
-addOpt_P a = updateState (\s -> s{opt_P = a : opt_P s})
-addOpt_C a = updateState (\s -> s{opt_C = a : opt_C s})
-addOpt_c a = updateState (\s -> s{opt_c = a : opt_c s})
-addOpt_a a = updateState (\s -> s{opt_a = a : opt_a s})
-addOpt_m a = updateState (\s -> s{opt_m = a : opt_m s})
-addOpt_l a = updateState (\s -> s{opt_l = a : opt_l s})
-addOpt_dll a = updateState (\s -> s{opt_dll = a : opt_dll s})
-
-addCmdlineHCInclude a =
- updateState (\s -> s{cmdline_hc_includes = a : cmdline_hc_includes s})
-
- -- we add to the options from the front, so we need to reverse the list
-getOpts :: (DriverState -> [a]) -> IO [a]
-getOpts opts = readState opts >>= return . reverse
-
-newHeapSize :: Integer -> IO ()
-newHeapSize new = updateState
- (\s -> let current = specific_heap_size s in
- s{ specific_heap_size = if new > current then new else current })
-
-newStackSize :: Integer -> IO ()
-newStackSize new = updateState
- (\s -> let current = specific_stack_size s in
- s{ specific_stack_size = if new > current then new else current })
-
------------------------------------------------------------------------------
--- Phases
-
-{-
-Phase of the | Suffix saying | Flag saying | (suffix of)
-compilation system | ``start here''| ``stop after''| output file
-
-literate pre-processor | .lhs | - | -
-C pre-processor (opt.) | - | -E | -
-Haskell compiler | .hs | -C, -S | .hc, .s
-C compiler (opt.) | .hc or .c | -S | .s
-assembler | .s or .S | -c | .o
-linker | other | - | a.out
--}
-
-data Phase
- = MkDependHS -- haskell dependency generation
- | Unlit
- | Cpp
- | Hsc
- | Cc
- | HCc -- Haskellised C (as opposed to vanilla C) compilation
- | Mangle -- assembly mangling, now done by a separate script.
- | SplitMangle -- after mangler if splitting
- | SplitAs
- | As
- | Ln
- deriving (Eq)
-
------------------------------------------------------------------------------
--- Errors
-
-data BarfKind
- = PhaseFailed String ExitCode
- | Interrupted
- | UsageError String -- prints the short usage msg after the error
- | OtherError String -- just prints the error message
- deriving Eq
-
-GLOBAL_VAR(prog_name, "ghc", String)
-
-get_prog_name = unsafePerformIO (readIORef prog_name) -- urk!
-
-instance Show BarfKind where
- showsPrec _ e = showString get_prog_name . showString ": " . showBarf e
-
-showBarf (UsageError str) = showString str . showChar '\n' . showString short_usage
-showBarf (OtherError str) = showString str
-showBarf (PhaseFailed phase code) =
- showString phase . showString " failed, code = " . shows code
-showBarf (Interrupted) = showString "interrupted"
-
-unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
-
-barfKindTc = mkTyCon "BarfKind"
-instance Typeable BarfKind where
- typeOf _ = mkAppTy barfKindTc []
-
------------------------------------------------------------------------------
--- Global compilation flags
-
-
- -- Cpp-related flags
-hs_source_cpp_opts = global
- [ "-D__HASKELL1__="++cHaskell1Version
- , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
- , "-D__HASKELL98__"
- , "-D__CONCURRENT_HASKELL__"
- ]
-
- -- Verbose
-GLOBAL_VAR(verbose, False, Bool)
-is_verbose = do v <- readIORef verbose; if v then return "-v" else return ""
-
- -- Keep output from intermediate phases
-GLOBAL_VAR(keep_hi_diffs, False, Bool)
-GLOBAL_VAR(keep_hc_files, False, Bool)
-GLOBAL_VAR(keep_s_files, False, Bool)
-GLOBAL_VAR(keep_raw_s_files, False, Bool)
-GLOBAL_VAR(keep_tmp_files, False, Bool)
-
- -- Misc
-GLOBAL_VAR(scale_sizes_by, 1.0, Double)
-GLOBAL_VAR(dry_run, False, Bool)
-#if !defined(HAVE_WIN32_DLL_SUPPORT) || defined(DONT_WANT_WIN32_DLL_SUPPORT)
-GLOBAL_VAR(static, True, Bool)
-#else
-GLOBAL_VAR(static, False, Bool)
-#endif
-GLOBAL_VAR(collect_ghc_timing, False, Bool)
-GLOBAL_VAR(do_asm_mangling, True, Bool)
-
------------------------------------------------------------------------------
--- Splitting object files (for libraries)
-
-GLOBAL_VAR(split_object_files, False, Bool)
-GLOBAL_VAR(split_prefix, "", String)
-GLOBAL_VAR(n_split_files, 0, Int)
-
-can_split :: Bool
-can_split = prefixMatch "i386" cTARGETPLATFORM
- || prefixMatch "alpha" cTARGETPLATFORM
- || prefixMatch "hppa" cTARGETPLATFORM
- || prefixMatch "m68k" cTARGETPLATFORM
- || prefixMatch "mips" cTARGETPLATFORM
- || prefixMatch "powerpc" cTARGETPLATFORM
- || prefixMatch "rs6000" cTARGETPLATFORM
- || prefixMatch "sparc" cTARGETPLATFORM
-
------------------------------------------------------------------------------
--- Compiler output options
-
-data HscLang
- = HscC
- | HscAsm
- | HscJava
- deriving Eq
-
-GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" &&
- (prefixMatch "i386" cTARGETPLATFORM ||
- prefixMatch "sparc" cTARGETPLATFORM)
- then HscAsm
- else HscC,
- HscLang)
-
-GLOBAL_VAR(output_dir, Nothing, Maybe String)
-GLOBAL_VAR(output_suf, Nothing, Maybe String)
-GLOBAL_VAR(output_file, Nothing, Maybe String)
-GLOBAL_VAR(output_hi, Nothing, Maybe String)
-
-GLOBAL_VAR(ld_inputs, [], [String])
-
-odir_ify :: String -> IO String
-odir_ify f = do
- odir_opt <- readIORef output_dir
- case odir_opt of
- Nothing -> return f
- Just d -> return (newdir d f)
-
-osuf_ify :: String -> IO String
-osuf_ify f = do
- osuf_opt <- readIORef output_suf
- case osuf_opt of
- Nothing -> return f
- Just s -> return (newsuf s f)
-
------------------------------------------------------------------------------
--- Hi Files
-
-GLOBAL_VAR(produceHi, True, Bool)
-GLOBAL_VAR(hi_on_stdout, False, Bool)
-GLOBAL_VAR(hi_with, "", String)
-GLOBAL_VAR(hi_suf, "hi", String)
-
-data HiDiffFlag = NormalHiDiffs | UsageHiDiffs | NoHiDiffs
-GLOBAL_VAR(hi_diffs, NoHiDiffs, HiDiffFlag)
-
------------------------------------------------------------------------------
--- Warnings & sanity checking
-
--- Warning packages that are controlled by -W and -Wall. The 'standard'
--- warnings that you get all the time are
---
--- -fwarn-overlapping-patterns
--- -fwarn-missing-methods
--- -fwarn-missing-fields
--- -fwarn-deprecations
--- -fwarn-duplicate-exports
---
--- these are turned off by -Wnot.
-
-standardWarnings = [ "-fwarn-overlapping-patterns"
- , "-fwarn-missing-methods"
- , "-fwarn-missing-fields"
- , "-fwarn-deprecations"
- , "-fwarn-duplicate-exports"
- ]
-minusWOpts = standardWarnings ++
- [ "-fwarn-unused-binds"
- , "-fwarn-unused-matches"
- , "-fwarn-incomplete-patterns"
- , "-fwarn-unused-imports"
- ]
-minusWallOpts = minusWOpts ++
- [ "-fwarn-type-defaults"
- , "-fwarn-name-shadowing"
- , "-fwarn-missing-signatures"
- , "-fwarn-hi-shadowing"
- ]
-
-data WarningState = W_default | W_ | W_all | W_not
-
------------------------------------------------------------------------------
--- Compiler optimisation options
-
-GLOBAL_VAR(opt_level, 0, Int)
-
-setOptLevel :: String -> IO ()
-setOptLevel "" = do { writeIORef opt_level 1; go_via_C }
-setOptLevel "not" = writeIORef opt_level 0
-setOptLevel [c] | isDigit c = do
- let level = ord c - ord '0'
- writeIORef opt_level level
- when (level >= 1) go_via_C
-setOptLevel s = unknownFlagErr ("-O"++s)
-
-go_via_C = do
- l <- readIORef hsc_lang
- case l of { HscAsm -> writeIORef hsc_lang HscC;
- _other -> return () }
-
-GLOBAL_VAR(opt_minus_o2_for_C, False, Bool)
-
-GLOBAL_VAR(opt_MaxSimplifierIterations, 4, Int)
-GLOBAL_VAR(opt_StgStats, False, Bool)
-GLOBAL_VAR(opt_UsageSPInf, False, Bool) -- Off by default
-
-hsc_minusO2_flags = hsc_minusO_flags -- for now
-
-hsc_minusNoO_flags = do
- iter <- readIORef opt_MaxSimplifierIterations
- return [
- "-fignore-interface-pragmas",
- "-fomit-interface-pragmas",
- "-fsimplify",
- "[",
- "-fmax-simplifier-iterations" ++ show iter,
- "]"
- ]
-
-hsc_minusO_flags = do
- iter <- readIORef opt_MaxSimplifierIterations
- usageSP <- readIORef opt_UsageSPInf
- stgstats <- readIORef opt_StgStats
-
- return [
- "-ffoldr-build-on",
-
- "-fdo-eta-reduction",
- "-fdo-lambda-eta-expansion",
- "-fcase-of-case",
- "-fcase-merge",
- "-flet-to-case",
-
- -- initial simplify: mk specialiser happy: minimum effort please
-
- "-fsimplify",
- "[",
- "-finline-phase0",
- -- Don't inline anything till full laziness has bitten
- -- In particular, inlining wrappers inhibits floating
- -- e.g. ...(case f x of ...)...
- -- ==> ...(case (case x of I# x# -> fw x#) of ...)...
- -- ==> ...(case x of I# x# -> case fw x# of ...)...
- -- and now the redex (f x) isn't floatable any more
-
- "-fno-rules",
- -- Similarly, don't apply any rules until after full
- -- laziness. Notably, list fusion can prevent floating.
-
- "-fno-case-of-case",
- -- Don't do case-of-case transformations.
- -- This makes full laziness work better
-
- "-fmax-simplifier-iterations2",
- "]",
-
- -- Specialisation is best done before full laziness
- -- so that overloaded functions have all their dictionary lambdas manifest
- "-fspecialise",
-
- "-ffloat-outwards",
- "-ffloat-inwards",
-
- "-fsimplify",
- "[",
- "-finline-phase1",
- -- Want to run with inline phase 1 after the specialiser to give
- -- maximum chance for fusion to work before we inline build/augment
- -- in phase 2. This made a difference in 'ansi' where an
- -- overloaded function wasn't inlined till too late.
- "-fmax-simplifier-iterations" ++ show iter,
- "]",
-
- -- infer usage information here in case we need it later.
- -- (add more of these where you need them --KSW 1999-04)
- if usageSP then "-fusagesp" else "",
-
- "-fsimplify",
- "[",
- -- Need inline-phase2 here so that build/augment get
- -- inlined. I found that spectral/hartel/genfft lost some useful
- -- strictness in the function sumcode' if augment is not inlined
- -- before strictness analysis runs
-
- "-finline-phase2",
- "-fmax-simplifier-iterations2",
- "]",
-
- "-fsimplify",
- "[",
- "-fmax-simplifier-iterations2",
- -- No -finline-phase: allow all Ids to be inlined now
- -- This gets foldr inlined before strictness analysis
- "]",
-
- "-fstrictness",
- "-fcpr-analyse",
- "-fworker-wrapper",
- "-fglom-binds",
-
- "-fsimplify",
- "[",
- "-fmax-simplifier-iterations" ++ show iter,
- -- No -finline-phase: allow all Ids to be inlined now
- "]",
-
- "-ffloat-outwards",
- -- nofib/spectral/hartel/wang doubles in speed if you
- -- do full laziness late in the day. It only happens
- -- after fusion and other stuff, so the early pass doesn't
- -- catch it. For the record, the redex is
- -- f_el22 (f_el21 r_midblock)
-
--- Leave out lambda lifting for now
--- "-fsimplify", -- Tidy up results of full laziness
--- "[",
--- "-fmax-simplifier-iterations2",
--- "]",
--- "-ffloat-outwards-full",
-
- -- We want CSE to follow the final full-laziness pass, because it may
- -- succeed in commoning up things floated out by full laziness.
- --
- -- CSE must immediately follow a simplification pass, because it relies
- -- on the no-shadowing invariant. See comments at the top of CSE.lhs
- -- So it must NOT follow float-inwards, which can give rise to shadowing,
- -- even if its input doesn't have shadows. Hence putting it between
- -- the two passes.
- "-fcse",
-
-
- "-ffloat-inwards",
-
--- Case-liberation for -O2. This should be after
--- strictness analysis and the simplification which follows it.
-
--- ( ($OptLevel != 2)
--- ? ""
--- : "-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 ]" ),
---
--- "-fliberate-case",
-
- -- Final clean-up simplification:
- "-fsimplify",
- "[",
- "-fmax-simplifier-iterations" ++ show iter,
- -- No -finline-phase: allow all Ids to be inlined now
- "]"
-
- ]
-
------------------------------------------------------------------------------
--- Paths & Libraries
-
-split_marker = ':' -- not configurable (ToDo)
-
-import_paths, include_paths, library_paths :: IORef [String]
-GLOBAL_VAR(import_paths, ["."], [String])
-GLOBAL_VAR(include_paths, ["."], [String])
-GLOBAL_VAR(library_paths, [], [String])
-
-GLOBAL_VAR(cmdline_libraries, [], [String])
-
-addToDirList :: IORef [String] -> String -> IO ()
-addToDirList ref path
- = do paths <- readIORef ref
- writeIORef ref (paths ++ split split_marker path)
-
------------------------------------------------------------------------------
--- Packages
-
-GLOBAL_VAR(package_config, (findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")), String)
-
-listPackages :: IO ()
-listPackages = do
- details <- readIORef package_details
- hPutStr stdout (listPkgs details)
- hPutChar stdout '\n'
- exitWith ExitSuccess
-
-newPackage :: IO ()
-newPackage = do
- checkConfigAccess
- details <- readIORef package_details
- hPutStr stdout "Reading package info from stdin... "
- stuff <- getContents
- let new_pkg = read stuff :: Package
- catchAll new_pkg
- (\_ -> throwDyn (OtherError "parse error in package info"))
- hPutStrLn stdout "done."
- if (name new_pkg `elem` map name details)
- then throwDyn (OtherError ("package `" ++ name new_pkg ++
- "' already installed"))
- else do
- conf_file <- readIORef package_config
- savePackageConfig conf_file
- maybeRestoreOldConfig conf_file $ do
- writeNewConfig conf_file ( ++ [new_pkg])
- exitWith ExitSuccess
-
-deletePackage :: String -> IO ()
-deletePackage pkg = do
- checkConfigAccess
- details <- readIORef package_details
- if (pkg `notElem` map name details)
- then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
- else do
- conf_file <- readIORef package_config
- savePackageConfig conf_file
- maybeRestoreOldConfig conf_file $ do
- writeNewConfig conf_file (filter ((/= pkg) . name))
- exitWith ExitSuccess
-
-checkConfigAccess :: IO ()
-checkConfigAccess = do
- conf_file <- readIORef package_config
- access <- getPermissions conf_file
- unless (writable access)
- (throwDyn (OtherError "you don't have permission to modify the package configuration file"))
-
-maybeRestoreOldConfig :: String -> IO () -> IO ()
-maybeRestoreOldConfig conf_file io
- = catchAllIO io (\e -> do
- hPutStr stdout "\nWARNING: an error was encountered while the new \n\
- \configuration was being written. Attempting to \n\
- \restore the old configuration... "
- system ("cp " ++ conf_file ++ ".old " ++ conf_file)
- hPutStrLn stdout "done."
- throw e
- )
-
-writeNewConfig :: String -> ([Package] -> [Package]) -> IO ()
-writeNewConfig conf_file fn = do
- hPutStr stdout "Writing new package config file... "
- old_details <- readIORef package_details
- h <- openFile conf_file WriteMode
- hPutStr h (dumpPackages (fn old_details))
- hClose h
- hPutStrLn stdout "done."
-
-savePackageConfig :: String -> IO ()
-savePackageConfig conf_file = do
- hPutStr stdout "Saving old package config file... "
- -- mv rather than cp because we've already done an hGetContents
- -- on this file so we won't be able to open it for writing
- -- unless we move the old one out of the way...
- system ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old")
- hPutStrLn stdout "done."
-
--- package list is maintained in dependency order
-packages = global ["std", "rts", "gmp"] :: IORef [String]
--- comma in value, so can't use macro, grrr
-{-# NOINLINE packages #-}
-
-addPackage :: String -> IO ()
-addPackage package
- = do pkg_details <- readIORef package_details
- case lookupPkg package pkg_details of
- Nothing -> throwDyn (OtherError ("unknown package name: " ++ package))
- Just details -> do
- ps <- readIORef packages
- unless (package `elem` ps) $ do
- mapM_ addPackage (package_deps details)
- ps <- readIORef packages
- writeIORef packages (package:ps)
-
-getPackageImportPath :: IO [String]
-getPackageImportPath = do
- ps <- readIORef packages
- ps' <- getPackageDetails ps
- return (nub (concat (map import_dirs ps')))
-
-getPackageIncludePath :: IO [String]
-getPackageIncludePath = do
- ps <- readIORef packages
- ps' <- getPackageDetails ps
- return (nub (filter (not.null) (concatMap include_dirs ps')))
-
- -- includes are in reverse dependency order (i.e. rts first)
-getPackageCIncludes :: IO [String]
-getPackageCIncludes = do
- ps <- readIORef packages
- ps' <- getPackageDetails ps
- return (reverse (nub (filter (not.null) (concatMap c_includes ps'))))
-
-getPackageLibraryPath :: IO [String]
-getPackageLibraryPath = do
- ps <- readIORef packages
- ps' <- getPackageDetails ps
- return (nub (concat (map library_dirs ps')))
-
-getPackageLibraries :: IO [String]
-getPackageLibraries = do
- ps <- readIORef packages
- ps' <- getPackageDetails ps
- tag <- readIORef build_tag
- let suffix = if null tag then "" else '_':tag
- return (concat (
- map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps'
- ))
-
-getPackageExtraGhcOpts :: IO [String]
-getPackageExtraGhcOpts = do
- ps <- readIORef packages
- ps' <- getPackageDetails ps
- return (concatMap extra_ghc_opts ps')
-
-getPackageExtraCcOpts :: IO [String]
-getPackageExtraCcOpts = do
- ps <- readIORef packages
- ps' <- getPackageDetails ps
- return (concatMap extra_cc_opts ps')
-
-getPackageExtraLdOpts :: IO [String]
-getPackageExtraLdOpts = do
- ps <- readIORef packages
- ps' <- getPackageDetails ps
- return (concatMap extra_ld_opts ps')
-
-getPackageDetails :: [String] -> IO [Package]
-getPackageDetails ps = do
- pkg_details <- readIORef package_details
- return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ]
-
-GLOBAL_VAR(package_details, (error "package_details"), [Package])
-
-lookupPkg :: String -> [Package] -> Maybe Package
-lookupPkg nm ps
- = case [p | p <- ps, name p == nm] of
- [] -> Nothing
- (p:_) -> Just p
-
------------------------------------------------------------------------------
--- Ways
-
--- The central concept of a "way" is that all objects in a given
--- program must be compiled in the same "way". Certain options change
--- parameters of the virtual machine, eg. profiling adds an extra word
--- to the object header, so profiling objects cannot be linked with
--- non-profiling objects.
-
--- After parsing the command-line options, we determine which "way" we
--- are building - this might be a combination way, eg. profiling+ticky-ticky.
-
--- We then find the "build-tag" associated with this way, and this
--- becomes the suffix used to find .hi files and libraries used in
--- this compilation.
-
-GLOBAL_VAR(build_tag, "", String)
-
-data WayName
- = WayProf
- | WayUnreg
- | WayDll
- | WayTicky
- | WayPar
- | WayGran
- | WaySMP
- | WayDebug
- | WayUser_a
- | WayUser_b
- | WayUser_c
- | WayUser_d
- | WayUser_e
- | WayUser_f
- | WayUser_g
- | WayUser_h
- | WayUser_i
- | WayUser_j
- | WayUser_k
- | WayUser_l
- | WayUser_m
- | WayUser_n
- | WayUser_o
- | WayUser_A
- | WayUser_B
- deriving (Eq,Ord)
-
-GLOBAL_VAR(ways, [] ,[WayName])
-
--- ToDo: allow WayDll with any other allowed combination
-
-allowed_combinations =
- [ [WayProf,WayUnreg],
- [WayProf,WaySMP] -- works???
- ]
-
-findBuildTag :: IO [String] -- new options
-findBuildTag = do
- way_names <- readIORef ways
- case sort way_names of
- [] -> do writeIORef build_tag ""
- return []
-
- [w] -> do let details = lkupWay w
- writeIORef build_tag (wayTag details)
- return (wayOpts details)
-
- ws -> if ws `notElem` allowed_combinations
- then throwDyn (OtherError $
- "combination not supported: " ++
- foldr1 (\a b -> a ++ '/':b)
- (map (wayName . lkupWay) ws))
- else let stuff = map lkupWay ws
- tag = concat (map wayTag stuff)
- flags = map wayOpts stuff
- in do
- writeIORef build_tag tag
- return (concat flags)
-
-lkupWay w =
- case lookup w way_details of
- Nothing -> error "findBuildTag"
- Just details -> details
-
-data Way = Way {
- wayTag :: String,
- wayName :: String,
- wayOpts :: [String]
- }
-
-way_details :: [ (WayName, Way) ]
-way_details =
- [ (WayProf, Way "p" "Profiling"
- [ "-fscc-profiling"
- , "-DPROFILING"
- , "-optc-DPROFILING"
- , "-fvia-C" ]),
-
- (WayTicky, Way "t" "Ticky-ticky Profiling"
- [ "-fticky-ticky"
- , "-DTICKY_TICKY"
- , "-optc-DTICKY_TICKY"
- , "-fvia-C" ]),
-
- (WayUnreg, Way "u" "Unregisterised"
- [ "-optc-DNO_REGS"
- , "-optc-DUSE_MINIINTERPRETER"
- , "-fno-asm-mangling"
- , "-funregisterised"
- , "-fvia-C" ]),
-
- (WayDll, Way "dll" "DLLized"
- [ ]),
-
- (WayPar, Way "mp" "Parallel"
- [ "-fparallel"
- , "-D__PARALLEL_HASKELL__"
- , "-optc-DPAR"
- , "-package concurrent"
- , "-fvia-C" ]),
-
- (WayGran, Way "mg" "Gransim"
- [ "-fgransim"
- , "-D__GRANSIM__"
- , "-optc-DGRAN"
- , "-package concurrent"
- , "-fvia-C" ]),
-
- (WaySMP, Way "s" "SMP"
- [ "-fsmp"
- , "-optc-pthread"
- , "-optl-pthread"
- , "-optc-DSMP"
- , "-fvia-C" ]),
-
- (WayUser_a, Way "a" "User way 'a'" ["$WAY_a_REAL_OPTS"]),
- (WayUser_b, Way "b" "User way 'b'" ["$WAY_b_REAL_OPTS"]),
- (WayUser_c, Way "c" "User way 'c'" ["$WAY_c_REAL_OPTS"]),
- (WayUser_d, Way "d" "User way 'd'" ["$WAY_d_REAL_OPTS"]),
- (WayUser_e, Way "e" "User way 'e'" ["$WAY_e_REAL_OPTS"]),
- (WayUser_f, Way "f" "User way 'f'" ["$WAY_f_REAL_OPTS"]),
- (WayUser_g, Way "g" "User way 'g'" ["$WAY_g_REAL_OPTS"]),
- (WayUser_h, Way "h" "User way 'h'" ["$WAY_h_REAL_OPTS"]),
- (WayUser_i, Way "i" "User way 'i'" ["$WAY_i_REAL_OPTS"]),
- (WayUser_j, Way "j" "User way 'j'" ["$WAY_j_REAL_OPTS"]),
- (WayUser_k, Way "k" "User way 'k'" ["$WAY_k_REAL_OPTS"]),
- (WayUser_l, Way "l" "User way 'l'" ["$WAY_l_REAL_OPTS"]),
- (WayUser_m, Way "m" "User way 'm'" ["$WAY_m_REAL_OPTS"]),
- (WayUser_n, Way "n" "User way 'n'" ["$WAY_n_REAL_OPTS"]),
- (WayUser_o, Way "o" "User way 'o'" ["$WAY_o_REAL_OPTS"]),
- (WayUser_A, Way "A" "User way 'A'" ["$WAY_A_REAL_OPTS"]),
- (WayUser_B, Way "B" "User way 'B'" ["$WAY_B_REAL_OPTS"])
- ]
-
------------------------------------------------------------------------------
--- Programs for particular phases
-
-GLOBAL_VAR(pgm_L, findFile "unlit" cGHC_UNLIT, String)
-GLOBAL_VAR(pgm_P, cRAWCPP, String)
-GLOBAL_VAR(pgm_C, findFile "hsc" cGHC_HSC, String)
-GLOBAL_VAR(pgm_c, cGCC, String)
-GLOBAL_VAR(pgm_m, findFile "ghc-asm" cGHC_MANGLER, String)
-GLOBAL_VAR(pgm_s, findFile "ghc-split" cGHC_SPLIT, String)
-GLOBAL_VAR(pgm_a, cGCC, String)
-GLOBAL_VAR(pgm_l, cGCC, String)
-
------------------------------------------------------------------------------
--- Via-C compilation stuff
-
--- flags returned are: ( all C compilations
--- , registerised HC compilations
--- )
-
-machdepCCOpts
- | prefixMatch "alpha" cTARGETPLATFORM
- = return ( ["-static"], [] )
-
- | prefixMatch "hppa" cTARGETPLATFORM
- -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
- -- (very nice, but too bad the HP /usr/include files don't agree.)
- = return ( ["-static", "-D_HPUX_SOURCE"], [] )
-
- | prefixMatch "m68k" cTARGETPLATFORM
- -- -fno-defer-pop : for the .hc files, we want all the pushing/
- -- popping of args to routines to be explicit; if we let things
- -- be deferred 'til after an STGJUMP, imminent death is certain!
- --
- -- -fomit-frame-pointer : *don't*
- -- It's better to have a6 completely tied up being a frame pointer
- -- rather than let GCC pick random things to do with it.
- -- (If we want to steal a6, then we would try to do things
- -- as on iX86, where we *do* steal the frame pointer [%ebp].)
- = return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
-
- | prefixMatch "i386" cTARGETPLATFORM
- -- -fno-defer-pop : basically the same game as for m68k
- --
- -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
- -- the fp (%ebp) for our register maps.
- = do n_regs <- readState stolen_x86_regs
- sta <- readIORef static
- return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" ],
- [ "-fno-defer-pop", "-fomit-frame-pointer",
- "-DSTOLEN_X86_REGS="++show n_regs ]
- )
-
- | prefixMatch "mips" cTARGETPLATFORM
- = return ( ["static"], [] )
-
- | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
- = return ( ["static"], ["-finhibit-size-directive"] )
-
- | otherwise
- = return ( [], [] )
-
------------------------------------------------------------------------------
--- Build the Hsc command line
-
-build_hsc_opts :: IO [String]
-build_hsc_opts = do
- opt_C_ <- getOpts opt_C -- misc hsc opts
-
- -- warnings
- warn_level <- readState warning_opt
- let warn_opts = case warn_level of
- W_default -> standardWarnings
- W_ -> minusWOpts
- W_all -> minusWallOpts
- W_not -> []
-
- -- optimisation
- minus_o <- readIORef opt_level
- optimisation_opts <-
- case minus_o of
- 0 -> hsc_minusNoO_flags
- 1 -> hsc_minusO_flags
- 2 -> hsc_minusO2_flags
- _ -> error "unknown opt level"
- -- ToDo: -Ofile
-
- -- STG passes
- ways_ <- readIORef ways
- let stg_massage | WayProf `elem` ways_ = "-fmassage-stg-for-profiling"
- | otherwise = ""
-
- stg_stats <- readIORef opt_StgStats
- let stg_stats_flag | stg_stats = "-dstg-stats"
- | otherwise = ""
-
- let stg_opts = [ stg_massage, stg_stats_flag, "-flet-no-escape" ]
- -- let-no-escape always on for now
-
- verb <- is_verbose
- let hi_vers = "-fhi-version="++cProjectVersionInt
- static <- (do s <- readIORef static; if s then return "-static" else return "")
-
- l <- readIORef hsc_lang
- let lang = case l of
- HscC -> "-olang=C"
- HscAsm -> "-olang=asm"
- HscJava -> "-olang=java"
-
- -- get hi-file suffix
- hisuf <- readIORef hi_suf
-
- -- hi-suffix for packages depends on the build tag.
- package_hisuf <-
- do tag <- readIORef build_tag
- if null tag
- then return "hi"
- else return (tag ++ "_hi")
-
- import_dirs <- readIORef import_paths
- package_import_dirs <- getPackageImportPath
-
- let hi_map = "-himap=" ++
- makeHiMap import_dirs hisuf
- package_import_dirs package_hisuf
- split_marker
-
- hi_map_sep = "-himap-sep=" ++ [split_marker]
-
- scale <- readIORef scale_sizes_by
- heap <- readState specific_heap_size
- stack <- readState specific_stack_size
-
- -- take into account -fno-* flags by removing the equivalent -f*
- -- flag from our list.
- anti_flags <- getOpts anti_opt_C
- let basic_opts = opt_C_ ++ warn_opts ++ optimisation_opts ++ stg_opts
- filtered_opts = filter (`notElem` anti_flags) basic_opts
-
- return
- (
- filtered_opts
- -- ToDo: C stub files
- ++ [ hi_vers, static, verb, lang, hi_map, hi_map_sep ]
- ++ rts_opts
- )
-
-makeHiMap
- (import_dirs :: [String])
- (hi_suffix :: String)
- (package_import_dirs :: [String])
- (package_hi_suffix :: String)
- (split_marker :: Char)
- = foldr (add_dir hi_suffix)
- (foldr (add_dir package_hi_suffix) "" package_import_dirs)
- import_dirs
- where
- add_dir hisuf dir str = dir ++ "%." ++ hisuf ++ split_marker : str
-
-
-getOptionsFromSource
- :: String -- input file
- -> IO [String] -- options, if any
-getOptionsFromSource file
- = do h <- openFile file ReadMode
- catchJust ioErrors (look h)
- (\e -> if isEOFError e then return [] else ioError e)
- where
- look h = do
- l <- hGetLine h
- case () of
- () | null l -> look h
- | prefixMatch "#" l -> look h
- | prefixMatch "{-# LINE" l -> look h -- -}
- | Just (opts:_) <- matchRegex optionRegex l
- -> return (words opts)
- | otherwise -> return []
-
-optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}" -- -}
-
------------------------------------------------------------------------------