-
-
Save chrisdone/96e228f12bdbc3c43d06718467e69029 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| -- <prana> | |
| {-# LANGUAGE AllowAmbiguousTypes #-} | |
| {-# LANGUAGE DeriveDataTypeable #-} | |
| {-# LANGUAGE RankNTypes #-} | |
| {-# LANGUAGE CPP #-} | |
| {-# LANGUAGE DataKinds #-} | |
| {-# LANGUAGE DefaultSignatures #-} | |
| {-# LANGUAGE DeriveFoldable #-} | |
| {-# LANGUAGE DeriveFunctor #-} | |
| {-# LANGUAGE DeriveGeneric #-} | |
| {-# LANGUAGE DeriveTraversable #-} | |
| {-# LANGUAGE EmptyCase #-} | |
| {-# LANGUAGE FlexibleContexts #-} | |
| {-# LANGUAGE FlexibleInstances #-} | |
| {-# LANGUAGE KindSignatures #-} | |
| {-# LANGUAGE LambdaCase #-} | |
| {-# LANGUAGE MultiParamTypeClasses #-} | |
| {-# LANGUAGE MultiWayIf #-} | |
| {-# LANGUAGE ScopedTypeVariables #-} | |
| {-# LANGUAGE TypeApplications #-} | |
| {-# LANGUAGE TypeFamilies #-} | |
| {-# LANGUAGE TypeOperators #-} | |
| {-# LANGUAGE UndecidableInstances #-} | |
| {-# OPTIONS_GHC -fno-warn-type-defaults #-} | |
| {-# LANGUAGE LambdaCase #-} | |
| {-# LANGUAGE OverloadedStrings #-} | |
| -- </prana> | |
| {-# LANGUAGE CPP, NondecreasingIndentation, TupleSections #-} | |
| {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} | |
| ----------------------------------------------------------------------------- | |
| -- | |
| -- GHC Driver program | |
| -- | |
| -- (c) The University of Glasgow 2005 | |
| -- | |
| ----------------------------------------------------------------------------- | |
| module Main where | |
| -- <prana> | |
| import GHC.Generics | |
| import Data.Word | |
| import Data.Semigroup | |
| import qualified DataCon as GHC | |
| import qualified FastString as GHC | |
| import Data.Data | |
| import qualified Unique as GHC | |
| import GHC.Real | |
| import qualified InstEnv as GHC | |
| import qualified Data.ByteString as S | |
| import qualified Data.ByteString.Char8 as S8 | |
| import qualified Data.ByteString.Lazy as L | |
| import qualified Data.ByteString.Builder as L | |
| import Data.ByteString (ByteString) | |
| import qualified Outputable as GHC | |
| import qualified HscTypes as GHC | |
| import qualified Literal as GHC | |
| import qualified Id as GHC | |
| import qualified Module as GHC | |
| import qualified CoreSyn | |
| import qualified Name as GHC | |
| -- </prana> | |
| -- The official GHC API | |
| import qualified GHC | |
| import GHC ( -- DynFlags(..), HscTarget(..), | |
| -- GhcMode(..), GhcLink(..), | |
| Ghc, GhcMonad(..), | |
| LoadHowMuch(..) ) | |
| import CmdLineParser | |
| -- Implementations of the various modes (--show-iface, mkdependHS. etc.) | |
| import LoadIface ( showIface ) | |
| import HscMain ( newHscEnv ) | |
| import DriverPipeline ( oneShot, compileFile ) | |
| import DriverMkDepend ( doMkDependHS ) | |
| #ifdef GHCI | |
| import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings ) | |
| #endif | |
| -- Frontend plugins | |
| #ifdef GHCI | |
| import DynamicLoading | |
| import Plugins | |
| #else | |
| import DynamicLoading ( pluginError ) | |
| #endif | |
| import Module ( ModuleName ) | |
| -- Various other random stuff that we need | |
| import Config | |
| import Constants | |
| import HscTypes | |
| import Packages ( pprPackages, pprPackagesSimple, pprModuleMap ) | |
| import DriverPhases | |
| import BasicTypes ( failed ) | |
| import StaticFlags | |
| import DynFlags | |
| import ErrUtils | |
| import FastString | |
| import Outputable hiding ((<>)) | |
| import qualified Outputable ((<>)) | |
| import SrcLoc | |
| import Util | |
| import Panic | |
| import UniqSupply | |
| import MonadUtils ( liftIO ) | |
| -- Imports for --abi-hash | |
| import LoadIface ( loadUserInterface ) | |
| import Module ( mkModuleName ) | |
| import Finder ( findImportedModule, cannotFindInterface ) | |
| import TcRnMonad ( initIfaceCheck ) | |
| import Binary ( openBinMem, put_, fingerprintBinMem ) | |
| -- Standard Haskell libraries | |
| import System.IO | |
| import System.Environment | |
| import System.Exit | |
| import System.FilePath | |
| import Control.Monad | |
| import Data.Char | |
| import Data.List | |
| import Data.Maybe | |
| ----------------------------------------------------------------------------- | |
| -- ToDo: | |
| -- time commands when run with -v | |
| -- user ways | |
| -- Win32 support: proper signal handling | |
| -- reading the package configuration file is too slow | |
| -- -K<size> | |
| ----------------------------------------------------------------------------- | |
| -- GHC's command-line interface | |
| main :: IO () | |
| main = do | |
| initGCStatistics -- See Note [-Bsymbolic and hooks] | |
| hSetBuffering stdout LineBuffering | |
| hSetBuffering stderr LineBuffering | |
| -- Handle GHC-specific character encoding flags, allowing us to control how | |
| -- GHC produces output regardless of OS. | |
| env <- getEnvironment | |
| case lookup "GHC_CHARENC" env of | |
| Just "UTF-8" -> do | |
| hSetEncoding stdout utf8 | |
| hSetEncoding stderr utf8 | |
| _ -> do | |
| -- Avoid GHC erroring out when trying to display unhandled characters | |
| hSetTranslit stdout | |
| hSetTranslit stderr | |
| GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do | |
| -- 1. extract the -B flag from the args | |
| argv0 <- getArgs | |
| let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 | |
| mbMinusB | null minusB_args = Nothing | |
| | otherwise = Just (drop 2 (last minusB_args)) | |
| let argv1' = map (mkGeneralLocated "on the commandline") argv1 | |
| (argv2, staticFlagWarnings) <- parseStaticFlags argv1' | |
| -- 2. Parse the "mode" flags (--make, --interactive etc.) | |
| (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 | |
| let flagWarnings = staticFlagWarnings ++ modeFlagWarnings | |
| -- If all we want to do is something like showing the version number | |
| -- then do it now, before we start a GHC session etc. This makes | |
| -- getting basic information much more resilient. | |
| -- In particular, if we wait until later before giving the version | |
| -- number then bootstrapping gets confused, as it tries to find out | |
| -- what version of GHC it's using before package.conf exists, so | |
| -- starting the session fails. | |
| case mode of | |
| Left preStartupMode -> | |
| do case preStartupMode of | |
| ShowSupportedExtensions -> showSupportedExtensions | |
| ShowVersion -> showVersion | |
| ShowNumVersion -> putStrLn cProjectVersion | |
| ShowOptions isInteractive -> showOptions isInteractive | |
| Right postStartupMode -> | |
| -- start our GHC session | |
| GHC.runGhc mbMinusB $ do | |
| dflags <- GHC.getSessionDynFlags | |
| case postStartupMode of | |
| Left preLoadMode -> | |
| liftIO $ do | |
| case preLoadMode of | |
| ShowInfo -> showInfo dflags | |
| ShowGhcUsage -> showGhcUsage dflags | |
| ShowGhciUsage -> showGhciUsage dflags | |
| PrintWithDynFlags f -> putStrLn (f dflags) | |
| Right postLoadMode -> | |
| main' postLoadMode dflags argv3 flagWarnings | |
| main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String] | |
| -> Ghc () | |
| main' postLoadMode dflags0 args flagWarnings = do | |
| -- set the default GhcMode, HscTarget and GhcLink. The HscTarget | |
| -- can be further adjusted on a module by module basis, using only | |
| -- the -fvia-C and -fasm flags. If the default HscTarget is not | |
| -- HscC or HscAsm, -fvia-C and -fasm have no effect. | |
| let dflt_target = hscTarget dflags0 | |
| (mode, lang, link) | |
| = case postLoadMode of | |
| DoInteractive -> (CompManager, HscInterpreted, LinkInMemory) | |
| DoEval _ -> (CompManager, HscInterpreted, LinkInMemory) | |
| DoMake -> (CompManager, dflt_target, LinkBinary) | |
| DoMkDependHS -> (MkDepend, dflt_target, LinkBinary) | |
| DoAbiHash -> (OneShot, dflt_target, LinkBinary) | |
| _ -> (OneShot, dflt_target, LinkBinary) | |
| let dflags1 = dflags0{ ghcMode = mode, | |
| hscTarget = lang, | |
| ghcLink = link, | |
| verbosity = case postLoadMode of | |
| DoEval _ -> 0 | |
| _other -> 1 | |
| } | |
| -- turn on -fimplicit-import-qualified for GHCi now, so that it | |
| -- can be overriden from the command-line | |
| -- XXX: this should really be in the interactive DynFlags, but | |
| -- we don't set that until later in interactiveUI | |
| dflags2 | DoInteractive <- postLoadMode = imp_qual_enabled | |
| | DoEval _ <- postLoadMode = imp_qual_enabled | |
| | otherwise = dflags1 | |
| where imp_qual_enabled = dflags1 `gopt_set` Opt_ImplicitImportQualified | |
| -- The rest of the arguments are "dynamic" | |
| -- Leftover ones are presumably files | |
| (dflags3, fileish_args, dynamicFlagWarnings) <- | |
| GHC.parseDynamicFlags dflags2 args | |
| let dflags4 = case lang of | |
| HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) -> | |
| let platform = targetPlatform dflags3 | |
| dflags3a = updateWays $ dflags3 { ways = interpWays } | |
| dflags3b = foldl gopt_set dflags3a | |
| $ concatMap (wayGeneralFlags platform) | |
| interpWays | |
| dflags3c = foldl gopt_unset dflags3b | |
| $ concatMap (wayUnsetGeneralFlags platform) | |
| interpWays | |
| in dflags3c | |
| _ -> | |
| dflags3 | |
| GHC.prettyPrintGhcErrors dflags4 $ do | |
| let flagWarnings' = flagWarnings ++ dynamicFlagWarnings | |
| handleSourceError (\e -> do | |
| GHC.printException e | |
| liftIO $ exitWith (ExitFailure 1)) $ do | |
| liftIO $ handleFlagWarnings dflags4 flagWarnings' | |
| liftIO $ showBanner postLoadMode dflags4 | |
| let | |
| -- To simplify the handling of filepaths, we normalise all filepaths right | |
| -- away - e.g., for win32 platforms, backslashes are converted | |
| -- into forward slashes. | |
| normal_fileish_paths = map (normalise . unLoc) fileish_args | |
| (srcs, objs) = partition_args normal_fileish_paths [] [] | |
| dflags5 = dflags4 { ldInputs = map (FileOption "") objs | |
| ++ ldInputs dflags4 } | |
| -- we've finished manipulating the DynFlags, update the session | |
| _ <- GHC.setSessionDynFlags dflags5 | |
| dflags6 <- GHC.getSessionDynFlags | |
| hsc_env <- GHC.getSession | |
| ---------------- Display configuration ----------- | |
| case verbosity dflags6 of | |
| v | v == 4 -> liftIO $ dumpPackagesSimple dflags6 | |
| | v >= 5 -> liftIO $ dumpPackages dflags6 | |
| | otherwise -> return () | |
| when (verbosity dflags6 >= 3) $ do | |
| liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) | |
| when (dopt Opt_D_dump_mod_map dflags6) . liftIO $ | |
| printInfoForUser (dflags6 { pprCols = 200 }) | |
| (pkgQual dflags6) (pprModuleMap dflags6) | |
| liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6) | |
| ---------------- Final sanity checking ----------- | |
| liftIO $ checkOptions postLoadMode dflags6 srcs objs | |
| ---------------- Do the business ----------- | |
| handleSourceError (\e -> do | |
| GHC.printException e | |
| liftIO $ exitWith (ExitFailure 1)) $ do | |
| case postLoadMode of | |
| ShowInterface f -> liftIO $ doShowIface dflags6 f | |
| DoMake -> doMake srcs | |
| DoMkDependHS -> doMkDependHS (map fst srcs) | |
| StopBefore p -> liftIO (oneShot hsc_env p srcs) | |
| DoInteractive -> ghciUI srcs Nothing | |
| DoEval exprs -> ghciUI srcs $ Just $ reverse exprs | |
| DoAbiHash -> abiHash (map fst srcs) | |
| ShowPackages -> liftIO $ showPackages dflags6 | |
| DoFrontend f -> doFrontend f srcs | |
| liftIO $ dumpFinalStats dflags6 | |
| ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () | |
| #ifndef GHCI | |
| ghciUI _ _ = throwGhcException (CmdLineError "not built for interactive use") | |
| #else | |
| ghciUI = interactiveUI defaultGhciSettings | |
| #endif | |
| -- ----------------------------------------------------------------------------- | |
| -- Splitting arguments into source files and object files. This is where we | |
| -- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source | |
| -- file indicating the phase specified by the -x option in force, if any. | |
| partition_args :: [String] -> [(String, Maybe Phase)] -> [String] | |
| -> ([(String, Maybe Phase)], [String]) | |
| partition_args [] srcs objs = (reverse srcs, reverse objs) | |
| partition_args ("-x":suff:args) srcs objs | |
| | "none" <- suff = partition_args args srcs objs | |
| | StopLn <- phase = partition_args args srcs (slurp ++ objs) | |
| | otherwise = partition_args rest (these_srcs ++ srcs) objs | |
| where phase = startPhase suff | |
| (slurp,rest) = break (== "-x") args | |
| these_srcs = zip slurp (repeat (Just phase)) | |
| partition_args (arg:args) srcs objs | |
| | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs | |
| | otherwise = partition_args args srcs (arg:objs) | |
| {- | |
| We split out the object files (.o, .dll) and add them | |
| to ldInputs for use by the linker. | |
| The following things should be considered compilation manager inputs: | |
| - haskell source files (strings ending in .hs, .lhs or other | |
| haskellish extension), | |
| - module names (not forgetting hierarchical module names), | |
| - things beginning with '-' are flags that were not recognised by | |
| the flag parser, and we want them to generate errors later in | |
| checkOptions, so we class them as source files (#5921) | |
| - and finally we consider everything not containing a '.' to be | |
| a comp manager input, as shorthand for a .hs or .lhs filename. | |
| Everything else is considered to be a linker object, and passed | |
| straight through to the linker. | |
| -} | |
| looks_like_an_input :: String -> Bool | |
| looks_like_an_input m = isSourceFilename m | |
| || looksLikeModuleName m | |
| || "-" `isPrefixOf` m | |
| || '.' `notElem` m | |
| -- ----------------------------------------------------------------------------- | |
| -- Option sanity checks | |
| -- | Ensure sanity of options. | |
| -- | |
| -- Throws 'UsageError' or 'CmdLineError' if not. | |
| checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO () | |
| -- Final sanity checking before kicking off a compilation (pipeline). | |
| checkOptions mode dflags srcs objs = do | |
| -- Complain about any unknown flags | |
| let unknown_opts = [ f | (f@('-':_), _) <- srcs ] | |
| when (notNull unknown_opts) (unknownFlagsErr unknown_opts) | |
| when (notNull (filter wayRTSOnly (ways dflags)) | |
| && isInterpretiveMode mode) $ | |
| hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi") | |
| -- -prof and --interactive are not a good combination | |
| when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays) | |
| && isInterpretiveMode mode | |
| && not (gopt Opt_ExternalInterpreter dflags)) $ | |
| do throwGhcException (UsageError | |
| "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).") | |
| -- -ohi sanity check | |
| if (isJust (outputHi dflags) && | |
| (isCompManagerMode mode || srcs `lengthExceeds` 1)) | |
| then throwGhcException (UsageError "-ohi can only be used when compiling a single source file") | |
| else do | |
| -- -o sanity checking | |
| if (srcs `lengthExceeds` 1 && isJust (outputFile dflags) | |
| && not (isLinkMode mode)) | |
| then throwGhcException (UsageError "can't apply -o to multiple source files") | |
| else do | |
| let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags) | |
| when (not_linking && not (null objs)) $ | |
| hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs) | |
| -- Check that there are some input files | |
| -- (except in the interactive case) | |
| if null srcs && (null objs || not_linking) && needsInputsMode mode | |
| then throwGhcException (UsageError "no input files") | |
| else do | |
| case mode of | |
| StopBefore HCc | hscTarget dflags /= HscC | |
| -> throwGhcException $ UsageError $ | |
| "the option -C is only available with an unregisterised GHC" | |
| _ -> return () | |
| -- Verify that output files point somewhere sensible. | |
| verifyOutputFiles dflags | |
| -- Compiler output options | |
| -- Called to verify that the output files point somewhere valid. | |
| -- | |
| -- The assumption is that the directory portion of these output | |
| -- options will have to exist by the time 'verifyOutputFiles' | |
| -- is invoked. | |
| -- | |
| -- We create the directories for -odir, -hidir, -outputdir etc. ourselves if | |
| -- they don't exist, so don't check for those here (#2278). | |
| verifyOutputFiles :: DynFlags -> IO () | |
| verifyOutputFiles dflags = do | |
| let ofile = outputFile dflags | |
| when (isJust ofile) $ do | |
| let fn = fromJust ofile | |
| flg <- doesDirNameExist fn | |
| when (not flg) (nonExistentDir "-o" fn) | |
| let ohi = outputHi dflags | |
| when (isJust ohi) $ do | |
| let hi = fromJust ohi | |
| flg <- doesDirNameExist hi | |
| when (not flg) (nonExistentDir "-ohi" hi) | |
| where | |
| nonExistentDir flg dir = | |
| throwGhcException (CmdLineError ("error: directory portion of " ++ | |
| show dir ++ " does not exist (used with " ++ | |
| show flg ++ " option.)")) | |
| ----------------------------------------------------------------------------- | |
| -- GHC modes of operation | |
| type Mode = Either PreStartupMode PostStartupMode | |
| type PostStartupMode = Either PreLoadMode PostLoadMode | |
| data PreStartupMode | |
| = ShowVersion -- ghc -V/--version | |
| | ShowNumVersion -- ghc --numeric-version | |
| | ShowSupportedExtensions -- ghc --supported-extensions | |
| | ShowOptions Bool {- isInteractive -} -- ghc --show-options | |
| showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode | |
| showVersionMode = mkPreStartupMode ShowVersion | |
| showNumVersionMode = mkPreStartupMode ShowNumVersion | |
| showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions | |
| showOptionsMode = mkPreStartupMode (ShowOptions False) | |
| mkPreStartupMode :: PreStartupMode -> Mode | |
| mkPreStartupMode = Left | |
| isShowVersionMode :: Mode -> Bool | |
| isShowVersionMode (Left ShowVersion) = True | |
| isShowVersionMode _ = False | |
| isShowNumVersionMode :: Mode -> Bool | |
| isShowNumVersionMode (Left ShowNumVersion) = True | |
| isShowNumVersionMode _ = False | |
| data PreLoadMode | |
| = ShowGhcUsage -- ghc -? | |
| | ShowGhciUsage -- ghci -? | |
| | ShowInfo -- ghc --info | |
| | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo | |
| showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode | |
| showGhcUsageMode = mkPreLoadMode ShowGhcUsage | |
| showGhciUsageMode = mkPreLoadMode ShowGhciUsage | |
| showInfoMode = mkPreLoadMode ShowInfo | |
| printSetting :: String -> Mode | |
| printSetting k = mkPreLoadMode (PrintWithDynFlags f) | |
| where f dflags = fromMaybe (panic ("Setting not found: " ++ show k)) | |
| $ lookup k (compilerInfo dflags) | |
| mkPreLoadMode :: PreLoadMode -> Mode | |
| mkPreLoadMode = Right . Left | |
| isShowGhcUsageMode :: Mode -> Bool | |
| isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True | |
| isShowGhcUsageMode _ = False | |
| isShowGhciUsageMode :: Mode -> Bool | |
| isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True | |
| isShowGhciUsageMode _ = False | |
| data PostLoadMode | |
| = ShowInterface FilePath -- ghc --show-iface | |
| | DoMkDependHS -- ghc -M | |
| | StopBefore Phase -- ghc -E | -C | -S | |
| -- StopBefore StopLn is the default | |
| | DoMake -- ghc --make | |
| | DoInteractive -- ghc --interactive | |
| | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"] | |
| | DoAbiHash -- ghc --abi-hash | |
| | ShowPackages -- ghc --show-packages | |
| | DoFrontend ModuleName -- ghc --frontend Plugin.Module | |
| doMkDependHSMode, doMakeMode, doInteractiveMode, | |
| doAbiHashMode, showPackagesMode :: Mode | |
| doMkDependHSMode = mkPostLoadMode DoMkDependHS | |
| doMakeMode = mkPostLoadMode DoMake | |
| doInteractiveMode = mkPostLoadMode DoInteractive | |
| doAbiHashMode = mkPostLoadMode DoAbiHash | |
| showPackagesMode = mkPostLoadMode ShowPackages | |
| showInterfaceMode :: FilePath -> Mode | |
| showInterfaceMode fp = mkPostLoadMode (ShowInterface fp) | |
| stopBeforeMode :: Phase -> Mode | |
| stopBeforeMode phase = mkPostLoadMode (StopBefore phase) | |
| doEvalMode :: String -> Mode | |
| doEvalMode str = mkPostLoadMode (DoEval [str]) | |
| doFrontendMode :: String -> Mode | |
| doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str)) | |
| mkPostLoadMode :: PostLoadMode -> Mode | |
| mkPostLoadMode = Right . Right | |
| isDoInteractiveMode :: Mode -> Bool | |
| isDoInteractiveMode (Right (Right DoInteractive)) = True | |
| isDoInteractiveMode _ = False | |
| isStopLnMode :: Mode -> Bool | |
| isStopLnMode (Right (Right (StopBefore StopLn))) = True | |
| isStopLnMode _ = False | |
| isDoMakeMode :: Mode -> Bool | |
| isDoMakeMode (Right (Right DoMake)) = True | |
| isDoMakeMode _ = False | |
| isDoEvalMode :: Mode -> Bool | |
| isDoEvalMode (Right (Right (DoEval _))) = True | |
| isDoEvalMode _ = False | |
| #ifdef GHCI | |
| isInteractiveMode :: PostLoadMode -> Bool | |
| isInteractiveMode DoInteractive = True | |
| isInteractiveMode _ = False | |
| #endif | |
| -- isInterpretiveMode: byte-code compiler involved | |
| isInterpretiveMode :: PostLoadMode -> Bool | |
| isInterpretiveMode DoInteractive = True | |
| isInterpretiveMode (DoEval _) = True | |
| isInterpretiveMode _ = False | |
| needsInputsMode :: PostLoadMode -> Bool | |
| needsInputsMode DoMkDependHS = True | |
| needsInputsMode (StopBefore _) = True | |
| needsInputsMode DoMake = True | |
| needsInputsMode _ = False | |
| -- True if we are going to attempt to link in this mode. | |
| -- (we might not actually link, depending on the GhcLink flag) | |
| isLinkMode :: PostLoadMode -> Bool | |
| isLinkMode (StopBefore StopLn) = True | |
| isLinkMode DoMake = True | |
| isLinkMode DoInteractive = True | |
| isLinkMode (DoEval _) = True | |
| isLinkMode _ = False | |
| isCompManagerMode :: PostLoadMode -> Bool | |
| isCompManagerMode DoMake = True | |
| isCompManagerMode DoInteractive = True | |
| isCompManagerMode (DoEval _) = True | |
| isCompManagerMode _ = False | |
| -- ----------------------------------------------------------------------------- | |
| -- Parsing the mode flag | |
| parseModeFlags :: [Located String] | |
| -> IO (Mode, | |
| [Located String], | |
| [Located String]) | |
| parseModeFlags args = do | |
| let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) = | |
| runCmdLine (processArgs mode_flags args) | |
| (Nothing, [], []) | |
| mode = case mModeFlag of | |
| Nothing -> doMakeMode | |
| Just (m, _) -> m | |
| -- See Note [Handling errors when parsing commandline flags] | |
| unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $ | |
| map (("on the commandline", )) $ map unLoc errs1 ++ errs2 | |
| return (mode, flags' ++ leftover, warns) | |
| type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String]) | |
| -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) | |
| -- so we collect the new ones and return them. | |
| mode_flags :: [Flag ModeM] | |
| mode_flags = | |
| [ ------- help / version ---------------------------------------------- | |
| defFlag "?" (PassFlag (setMode showGhcUsageMode)) | |
| , defFlag "-help" (PassFlag (setMode showGhcUsageMode)) | |
| , defFlag "V" (PassFlag (setMode showVersionMode)) | |
| , defFlag "-version" (PassFlag (setMode showVersionMode)) | |
| , defFlag "-numeric-version" (PassFlag (setMode showNumVersionMode)) | |
| , defFlag "-info" (PassFlag (setMode showInfoMode)) | |
| , defFlag "-show-options" (PassFlag (setMode showOptionsMode)) | |
| , defFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode)) | |
| , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode)) | |
| , defFlag "-show-packages" (PassFlag (setMode showPackagesMode)) | |
| ] ++ | |
| [ defFlag k' (PassFlag (setMode (printSetting k))) | |
| | k <- ["Project version", | |
| "Project Git commit id", | |
| "Booter version", | |
| "Stage", | |
| "Build platform", | |
| "Host platform", | |
| "Target platform", | |
| "Have interpreter", | |
| "Object splitting supported", | |
| "Have native code generator", | |
| "Support SMP", | |
| "Unregisterised", | |
| "Tables next to code", | |
| "RTS ways", | |
| "Leading underscore", | |
| "Debug on", | |
| "LibDir", | |
| "Global Package DB", | |
| "C compiler flags", | |
| "C compiler link flags", | |
| "ld flags"], | |
| let k' = "-print-" ++ map (replaceSpace . toLower) k | |
| replaceSpace ' ' = '-' | |
| replaceSpace c = c | |
| ] ++ | |
| ------- interfaces ---------------------------------------------------- | |
| [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) | |
| "--show-iface")) | |
| ------- primary modes ------------------------------------------------ | |
| , defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f | |
| addFlag "-no-link" f)) | |
| , defFlag "M" (PassFlag (setMode doMkDependHSMode)) | |
| , defFlag "E" (PassFlag (setMode (stopBeforeMode anyHsc))) | |
| , defFlag "C" (PassFlag (setMode (stopBeforeMode HCc))) | |
| , defFlag "S" (PassFlag (setMode (stopBeforeMode (As False)))) | |
| , defFlag "-make" (PassFlag (setMode doMakeMode)) | |
| , defFlag "-interactive" (PassFlag (setMode doInteractiveMode)) | |
| , defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode)) | |
| , defFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e")) | |
| , defFlag "-frontend" (SepArg (\s -> setMode (doFrontendMode s) "-frontend")) | |
| ] | |
| setMode :: Mode -> String -> EwM ModeM () | |
| setMode newMode newFlag = liftEwM $ do | |
| (mModeFlag, errs, flags') <- getCmdLineState | |
| let (modeFlag', errs') = | |
| case mModeFlag of | |
| Nothing -> ((newMode, newFlag), errs) | |
| Just (oldMode, oldFlag) -> | |
| case (oldMode, newMode) of | |
| -- -c/--make are allowed together, and mean --make -no-link | |
| _ | isStopLnMode oldMode && isDoMakeMode newMode | |
| || isStopLnMode newMode && isDoMakeMode oldMode -> | |
| ((doMakeMode, "--make"), []) | |
| -- If we have both --help and --interactive then we | |
| -- want showGhciUsage | |
| _ | isShowGhcUsageMode oldMode && | |
| isDoInteractiveMode newMode -> | |
| ((showGhciUsageMode, oldFlag), []) | |
| | isShowGhcUsageMode newMode && | |
| isDoInteractiveMode oldMode -> | |
| ((showGhciUsageMode, newFlag), []) | |
| -- If we have both -e and --interactive then -e always wins | |
| _ | isDoEvalMode oldMode && | |
| isDoInteractiveMode newMode -> | |
| ((oldMode, oldFlag), []) | |
| | isDoEvalMode newMode && | |
| isDoInteractiveMode oldMode -> | |
| ((newMode, newFlag), []) | |
| -- Otherwise, --help/--version/--numeric-version always win | |
| | isDominantFlag oldMode -> ((oldMode, oldFlag), []) | |
| | isDominantFlag newMode -> ((newMode, newFlag), []) | |
| -- We need to accumulate eval flags like "-e foo -e bar" | |
| (Right (Right (DoEval esOld)), | |
| Right (Right (DoEval [eNew]))) -> | |
| ((Right (Right (DoEval (eNew : esOld))), oldFlag), | |
| errs) | |
| -- Saying e.g. --interactive --interactive is OK | |
| _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs) | |
| -- --interactive and --show-options are used together | |
| (Right (Right DoInteractive), Left (ShowOptions _)) -> | |
| ((Left (ShowOptions True), | |
| "--interactive --show-options"), errs) | |
| (Left (ShowOptions _), (Right (Right DoInteractive))) -> | |
| ((Left (ShowOptions True), | |
| "--show-options --interactive"), errs) | |
| -- Otherwise, complain | |
| _ -> let err = flagMismatchErr oldFlag newFlag | |
| in ((oldMode, oldFlag), err : errs) | |
| putCmdLineState (Just modeFlag', errs', flags') | |
| where isDominantFlag f = isShowGhcUsageMode f || | |
| isShowGhciUsageMode f || | |
| isShowVersionMode f || | |
| isShowNumVersionMode f | |
| flagMismatchErr :: String -> String -> String | |
| flagMismatchErr oldFlag newFlag | |
| = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'" | |
| addFlag :: String -> String -> EwM ModeM () | |
| addFlag s flag = liftEwM $ do | |
| (m, e, flags') <- getCmdLineState | |
| putCmdLineState (m, e, mkGeneralLocated loc s : flags') | |
| where loc = "addFlag by " ++ flag ++ " on the commandline" | |
| -- ---------------------------------------------------------------------------- | |
| -- Run --make mode | |
| doMake :: [(String,Maybe Phase)] -> Ghc () | |
| doMake srcs = do | |
| let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs | |
| hsc_env <- GHC.getSession | |
| -- if we have no haskell sources from which to do a dependency | |
| -- analysis, then just do one-shot compilation and/or linking. | |
| -- This means that "ghc Foo.o Bar.o -o baz" links the program as | |
| -- we expect. | |
| if (null hs_srcs) | |
| then liftIO (oneShot hsc_env StopLn srcs) | |
| else do | |
| o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) | |
| non_hs_srcs | |
| dflags <- GHC.getSessionDynFlags | |
| let dflags' = dflags { ldInputs = map (FileOption "") o_files | |
| ++ ldInputs dflags } | |
| _ <- GHC.setSessionDynFlags dflags' | |
| targets <- mapM (uncurry GHC.guessTarget) hs_srcs | |
| GHC.setTargets targets | |
| ok_flag <- GHC.load LoadAllTargets | |
| when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) | |
| return () | |
| -- <prana> | |
| mgraph <- GHC.getModuleGraph | |
| mapM_ | |
| (\modSummary -> do | |
| liftIO (hPutStrLn stderr ("Writing " ++ moduleToFilePath (GHC.ms_mod modSummary))) | |
| guts <- compile modSummary | |
| let bs = GHC.mg_binds guts | |
| instances :: [GHC.ClsInst] | |
| instances = GHC.mg_insts guts | |
| methods :: [(GHC.Id, Int)] | |
| methods = | |
| concatMap | |
| (\clsInst -> | |
| let tyVars = GHC.is_tvs clsInst | |
| cls = GHC.is_cls clsInst | |
| methods = GHC.classMethods cls | |
| in zip methods [0 ..]) | |
| instances | |
| let module' = GHC.ms_mod modSummary | |
| bindings = | |
| encodeArray | |
| (map (encodeBind . toBind module') | |
| bs) | |
| methodIndices = | |
| encodeArray | |
| (map (\(id,i) -> encodeId (toId module' id) <> encodeInt i) | |
| methods) | |
| -- dataCons = | |
| -- encodeArray (map {-isDataConName-}) | |
| liftIO | |
| (L.writeFile | |
| (moduleToFilePath (GHC.ms_mod modSummary)) | |
| (L.toLazyByteString (methodIndices <> bindings)))) | |
| mgraph | |
| toBind :: GHC.Module -> CoreSyn.Bind GHC.Var -> Main.Bind | |
| toBind m = \case | |
| CoreSyn.NonRec v e -> Main.NonRec (toId m v) (toExp m e) | |
| CoreSyn.Rec bs -> Main.Rec (map (\(v,e) -> (toId m v,toExp m e)) bs) | |
| toExp :: GHC.Module -> CoreSyn.Expr GHC.Var -> Main.Exp | |
| toExp m = \case | |
| CoreSyn.Var i -> Main.VarE (toId m i) | |
| CoreSyn.Lit i -> Main.LitE (toLit i) | |
| CoreSyn.App f x -> Main.AppE (toExp m f) (toExp m x) | |
| CoreSyn.Lam var body -> Main.LamE (toId m var) (toExp m body) | |
| CoreSyn.Let bind expr -> Main.LetE (toBind m bind) (toExp m expr) | |
| CoreSyn.Case expr var typ alts -> Main.CaseE (toExp m expr) (toId m var) (toTyp typ) (map (toAlt m) alts) | |
| CoreSyn.Cast expr _coercion -> Main.CastE (toExp m expr) | |
| CoreSyn.Tick _tickishVar expr -> Main.TickE (toExp m expr) | |
| CoreSyn.Type typ -> Main.TypE (toTyp typ) | |
| CoreSyn.Coercion _coercion -> Main.CoercionE | |
| toAlt :: GHC.Module -> (CoreSyn.AltCon, [GHC.Var], CoreSyn.Expr GHC.Var) -> Alt | |
| toAlt m (con,vars,e) = Alt (toAltCon con) (map (toId m) vars) (toExp m e) | |
| toAltCon :: CoreSyn.AltCon -> Main.AltCon | |
| toAltCon = | |
| \case | |
| CoreSyn.DataAlt dataCon -> DataAlt (toDataCon dataCon) | |
| CoreSyn.LitAlt literal -> LitAlt (toLit literal) | |
| CoreSyn.DEFAULT -> DEFAULT | |
| toLit :: GHC.Literal -> Main.Lit | |
| toLit = | |
| \case | |
| GHC.MachChar i -> Char i | |
| GHC.MachStr i -> Str i | |
| GHC.MachNullAddr -> NullAddr | |
| GHC.MachInt i -> Int i | |
| GHC.MachInt64 i -> Int64 i | |
| GHC.MachWord i -> Word i | |
| GHC.MachWord64 i -> Word64 i | |
| GHC.MachFloat (i) -> Float i | |
| GHC.MachDouble (i) -> Double i | |
| GHC.MachLabel _ _ _ -> Label | |
| GHC.LitInteger i _typ -> Integer i | |
| toTyp :: GHC.Type -> Main.Typ | |
| toTyp v = Main.Typ (S8.pack (GHC.showSDocUnsafe (GHC.ppr v))) | |
| toDataCon :: GHC.DataCon -> Main.DataCon | |
| toDataCon = Main.DataCon . Main.Unique . GHC.getKey . GHC.getUnique . GHC.dataConName | |
| toId :: GHC.Module -> GHC.Id -> Main.Id | |
| toId m thing = Main.Id bs unique cat | |
| where | |
| (bs,cat) = | |
| qualifiedNameByteString | |
| (if GHC.isInternalName name | |
| then qualify m name | |
| else name) | |
| unique = Main.Unique (GHC.getKey (GHC.getUnique name)) | |
| name = GHC.getName thing | |
| qualify :: GHC.Module -> GHC.Name -> GHC.Name | |
| qualify m name = | |
| GHC.mkExternalName | |
| (GHC.getUnique name) | |
| m | |
| (GHC.nameOccName name) | |
| (GHC.nameSrcSpan name) | |
| qualifiedNameByteString :: GHC.Name -> (ByteString,Cat) | |
| qualifiedNameByteString n = | |
| case GHC.nameModule_maybe n of | |
| Nothing -> (sort' <> ":" <> ident, ValCat) | |
| where sort' = | |
| if GHC.isInternalName n | |
| then "internal" | |
| else if GHC.isSystemName n | |
| then "system" | |
| else "unknown" | |
| Just mo -> | |
| ( package <> ":" <> module' <> "." <> ident | |
| , if S.isPrefixOf "C:" ident | |
| then ClassCat | |
| else if S8.all isUpper (S.take 1 ident) | |
| then DataCat | |
| else if S8.all (\c -> c=='(' || c==')' || c==',') ident | |
| then DataCat | |
| else ValCat) | |
| where package = GHC.fs_bs (GHC.unitIdFS (GHC.moduleUnitId mo)) | |
| module' = GHC.fs_bs (GHC.moduleNameFS (GHC.moduleName mo)) | |
| where | |
| ident = GHC.fs_bs (GHC.getOccFS n) | |
| compile :: | |
| GHC.GhcMonad m | |
| => GHC.ModSummary | |
| -> m GHC.ModGuts | |
| compile modSummary = do | |
| parsedModule <- GHC.parseModule modSummary | |
| typecheckedModule <- GHC.typecheckModule parsedModule | |
| desugared <- GHC.desugarModule typecheckedModule | |
| pure (GHC.dm_core_module desugared) | |
| moduleToFilePath :: GHC.Module -> FilePath | |
| moduleToFilePath module' = packageNameVersion ++ "_" ++ moduleNameString ++ ".prana" | |
| where | |
| unitId = GHC.moduleUnitId module' | |
| moduleName_ = GHC.moduleName module' | |
| packageNameVersion = GHC.unitIdString unitId | |
| moduleNameString = GHC.moduleNameString moduleName_ | |
| -- </prana> | |
| -- --------------------------------------------------------------------------- | |
| -- --show-iface mode | |
| doShowIface :: DynFlags -> FilePath -> IO () | |
| doShowIface dflags file = do | |
| hsc_env <- newHscEnv dflags | |
| showIface hsc_env file | |
| -- --------------------------------------------------------------------------- | |
| -- Various banners and verbosity output. | |
| showBanner :: PostLoadMode -> DynFlags -> IO () | |
| showBanner _postLoadMode dflags = do | |
| let verb = verbosity dflags | |
| #ifdef GHCI | |
| -- Show the GHCi banner | |
| when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg | |
| #endif | |
| -- Display details of the configuration in verbose mode | |
| when (verb >= 2) $ | |
| do hPutStr stderr "Glasgow Haskell Compiler, Version " | |
| hPutStr stderr cProjectVersion | |
| hPutStr stderr ", stage " | |
| hPutStr stderr cStage | |
| hPutStr stderr " booted by GHC version " | |
| hPutStrLn stderr cBooterVersion | |
| -- We print out a Read-friendly string, but a prettier one than the | |
| -- Show instance gives us | |
| showInfo :: DynFlags -> IO () | |
| showInfo dflags = do | |
| let sq x = " [" ++ x ++ "\n ]" | |
| putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags | |
| showSupportedExtensions :: IO () | |
| showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions | |
| showVersion :: IO () | |
| showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion) | |
| showOptions :: Bool -> IO () | |
| showOptions isInteractive = putStr (unlines availableOptions) | |
| where | |
| availableOptions = concat [ | |
| flagsForCompletion isInteractive, | |
| map ('-':) (concat [ | |
| getFlagNames mode_flags | |
| , (filterUnwantedStatic . getFlagNames $ flagsStatic) | |
| , flagsStaticNames | |
| ]) | |
| ] | |
| getFlagNames opts = map flagName opts | |
| -- this is a hack to get rid of two unwanted entries that get listed | |
| -- as static flags. Hopefully this hack will disappear one day together | |
| -- with static flags | |
| filterUnwantedStatic = filter (`notElem`["f", "fno-"]) | |
| showGhcUsage :: DynFlags -> IO () | |
| showGhcUsage = showUsage False | |
| showGhciUsage :: DynFlags -> IO () | |
| showGhciUsage = showUsage True | |
| showUsage :: Bool -> DynFlags -> IO () | |
| showUsage ghci dflags = do | |
| let usage_path = if ghci then ghciUsagePath dflags | |
| else ghcUsagePath dflags | |
| usage <- readFile usage_path | |
| dump usage | |
| where | |
| dump "" = return () | |
| dump ('$':'$':s) = putStr progName >> dump s | |
| dump (c:s) = putChar c >> dump s | |
| dumpFinalStats :: DynFlags -> IO () | |
| dumpFinalStats dflags = | |
| when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags | |
| dumpFastStringStats :: DynFlags -> IO () | |
| dumpFastStringStats dflags = do | |
| buckets <- getFastStringTable | |
| let (entries, longest, has_z) = countFS 0 0 0 buckets | |
| msg = text "FastString stats:" $$ | |
| nest 4 (vcat [text "size: " <+> int (length buckets), | |
| text "entries: " <+> int entries, | |
| text "longest chain: " <+> int longest, | |
| text "has z-encoding: " <+> (has_z `pcntOf` entries) | |
| ]) | |
| -- we usually get more "has z-encoding" than "z-encoded", because | |
| -- when we z-encode a string it might hash to the exact same string, | |
| -- which will is not counted as "z-encoded". Only strings whose | |
| -- Z-encoding is different from the original string are counted in | |
| -- the "z-encoded" total. | |
| putMsg dflags msg | |
| where | |
| x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%' | |
| countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int) | |
| countFS entries longest has_z [] = (entries, longest, has_z) | |
| countFS entries longest has_z (b:bs) = | |
| let | |
| len = length b | |
| longest' = max len longest | |
| entries' = entries + len | |
| has_zs = length (filter hasZEncoding b) | |
| in | |
| countFS entries' longest' (has_z + has_zs) bs | |
| showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO () | |
| showPackages dflags = putStrLn (showSDoc dflags (pprPackages dflags)) | |
| dumpPackages dflags = putMsg dflags (pprPackages dflags) | |
| dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags) | |
| -- ----------------------------------------------------------------------------- | |
| -- Frontend plugin support | |
| doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc () | |
| #ifndef GHCI | |
| doFrontend modname _ = pluginError [modname] | |
| #else | |
| doFrontend modname srcs = do | |
| hsc_env <- getSession | |
| frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname | |
| frontend frontend_plugin (frontendPluginOpts (hsc_dflags hsc_env)) srcs | |
| #endif | |
| -- ----------------------------------------------------------------------------- | |
| -- ABI hash support | |
| {- | |
| ghc --abi-hash Data.Foo System.Bar | |
| Generates a combined hash of the ABI for modules Data.Foo and | |
| System.Bar. The modules must already be compiled, and appropriate -i | |
| options may be necessary in order to find the .hi files. | |
| This is used by Cabal for generating the ComponentId for a | |
| package. The ComponentId must change when the visible ABI of | |
| the package chagnes, so during registration Cabal calls ghc --abi-hash | |
| to get a hash of the package's ABI. | |
| -} | |
| -- | Print ABI hash of input modules. | |
| -- | |
| -- The resulting hash is the MD5 of the GHC version used (Trac #5328, | |
| -- see 'hiVersion') and of the existing ABI hash from each module (see | |
| -- 'mi_mod_hash'). | |
| abiHash :: [String] -- ^ List of module names | |
| -> Ghc () | |
| abiHash strs = do | |
| hsc_env <- getSession | |
| let dflags = hsc_dflags hsc_env | |
| liftIO $ do | |
| let find_it str = do | |
| let modname = mkModuleName str | |
| r <- findImportedModule hsc_env modname Nothing | |
| case r of | |
| Found _ m -> return m | |
| _error -> throwGhcException $ CmdLineError $ showSDoc dflags $ | |
| cannotFindInterface dflags modname r | |
| mods <- mapM find_it strs | |
| let get_iface modl = loadUserInterface False (text "abiHash") modl | |
| ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods | |
| bh <- openBinMem (3*1024) -- just less than a block | |
| put_ bh hiVersion | |
| -- package hashes change when the compiler version changes (for now) | |
| -- see #5328 | |
| mapM_ (put_ bh . mi_mod_hash) ifaces | |
| f <- fingerprintBinMem bh | |
| putStrLn (showPpr dflags f) | |
| -- ----------------------------------------------------------------------------- | |
| -- Util | |
| unknownFlagsErr :: [String] -> a | |
| unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs | |
| where | |
| oneError f = | |
| "unrecognised flag: " ++ f ++ "\n" ++ | |
| (case fuzzyMatch f (nub allNonDeprecatedFlags) of | |
| [] -> "" | |
| suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs)) | |
| {- Note [-Bsymbolic and hooks] | |
| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ | |
| -Bsymbolic is a flag that prevents the binding of references to global | |
| symbols to symbols outside the shared library being compiled (see `man | |
| ld`). When dynamically linking, we don't use -Bsymbolic on the RTS | |
| package: that is because we want hooks to be overridden by the user, | |
| we don't want to constrain them to the RTS package. | |
| Unfortunately this seems to have broken somehow on OS X: as a result, | |
| defaultHooks (in hschooks.c) is not called, which does not initialize | |
| the GC stats. As a result, this breaks things like `:set +s` in GHCi | |
| (#8754). As a hacky workaround, we instead call 'defaultHooks' | |
| directly to initalize the flags in the RTS. | |
| A byproduct of this, I believe, is that hooks are likely broken on OS | |
| X when dynamically linking. But this probably doesn't affect most | |
| people since we're linking GHC dynamically, but most things themselves | |
| link statically. | |
| -} | |
| foreign import ccall safe "initGCStatistics" | |
| initGCStatistics :: IO () | |
| -------------------------------------------------------------------------------- | |
| -- SYB | |
| type GenericQ r = forall a. Data a => a -> r | |
| everything :: (r -> r -> r) -> GenericQ r -> GenericQ r | |
| everything k f x = foldl k (f x) (gmapQ (everything k f) x) | |
| listify :: Typeable r => (r -> Bool) -> GenericQ [r] | |
| listify p = everything (++) ([] `mkQ` (\x -> if p x then [x] else [])) | |
| mkQ :: ( Typeable a , Typeable b) => r -> (b -> r) -> a -> r | |
| (r `mkQ` br) a = case cast a of | |
| Just b -> br b | |
| Nothing -> r | |
| -------------------------------------------------------------------------------- | |
| -- Binary writing | |
| encodeBind :: Main.Bind -> L.Builder | |
| encodeBind = | |
| \case | |
| Main.NonRec var expr -> tag 0 <> encodeId var <> encodeExpr expr | |
| Main.Rec pairs -> tag 1 <> encodeArray (map (\(v, e) -> encodeId v <> encodeExpr e) pairs) | |
| encodeExpr :: Main.Exp -> L.Builder | |
| encodeExpr = | |
| \case | |
| Main.VarE i -> tag 0 <> encodeId i | |
| Main.LitE i -> tag 1 <> encodeLit i | |
| Main.AppE f x -> tag 2 <> encodeExpr f <> encodeExpr x | |
| Main.LamE var body -> tag 3 <> encodeId var <> encodeExpr body | |
| Main.LetE bind expr -> tag 4 <> encodeBind bind <> encodeExpr expr | |
| Main.CaseE expr var typ alts -> tag 5 <> encodeExpr expr <> encodeId var <> encodeType typ <> encodeArray (map encodeAlt alts) | |
| Main.CastE expr -> tag 6 <> encodeExpr expr | |
| Main.TickE expr -> tag 7 <> encodeExpr expr | |
| Main.TypE typ -> tag 8 <> encodeType typ | |
| Main.CoercionE -> tag 9 | |
| encodeLit :: Main.Lit -> L.Builder | |
| encodeLit = | |
| \case | |
| Char i -> tag 0 <> encodeChar i | |
| Str i -> tag 1 <> encodeByteString i | |
| NullAddr -> tag 2 | |
| Int i -> tag 3 <> encodeInteger i | |
| Int64 i -> tag 4 <> encodeInteger i | |
| Word i -> tag 5 <> encodeInteger i | |
| Word64 i -> tag 6 <> encodeInteger i | |
| Float (i :% j) -> tag 7 <> encodeInteger i <> encodeInteger j | |
| Double (i :% j) -> tag 8 <> encodeInteger i <> encodeInteger j | |
| Label -> tag 9 | |
| Integer i -> tag 10 <> encodeInteger i | |
| encodeInteger :: Integer -> L.Builder | |
| encodeInteger = encodeLazyByteString . L.toLazyByteString . L.integerDec | |
| encodeInt :: Int -> L.Builder | |
| encodeInt = L.int64LE . fromIntegral | |
| encodeAltCon :: AltCon -> L.Builder | |
| encodeAltCon = | |
| \case | |
| DataAlt dataCon -> tag 0 <> encodeDataCon dataCon | |
| LitAlt literal -> tag 1 <> encodeLit literal | |
| DEFAULT -> tag 2 | |
| encodeAlt :: Alt -> L.Builder | |
| encodeAlt (Alt altCon' vars expr) = | |
| encodeAltCon altCon' <> encodeArray (map encodeId vars) <> encodeExpr expr | |
| tag :: Word8 -> L.Builder | |
| tag = L.word8 | |
| encodeType :: Typ -> L.Builder | |
| encodeType (Typ e) = encodeByteString e | |
| encodeId :: Id -> L.Builder | |
| encodeId (Id bs u isDataCon) = encodeByteString bs <> encodeUnique u <> encodeCat isDataCon | |
| encodeCat :: Cat -> L.Builder | |
| encodeCat = | |
| L.word8 . | |
| (\case | |
| ValCat -> 0 | |
| DataCat -> 1 | |
| ClassCat -> 2) | |
| encodeDataCon :: DataCon -> L.Builder | |
| encodeDataCon (DataCon e) = encodeUnique e | |
| encodeUnique :: Unique -> L.Builder | |
| encodeUnique (Unique x) = L.int64LE (fromIntegral x) | |
| encodeByteString :: ByteString -> L.Builder | |
| encodeByteString x = | |
| L.int64LE (fromIntegral (S.length x)) <> | |
| L.byteString x | |
| encodeLazyByteString :: L.ByteString -> L.Builder | |
| encodeLazyByteString x = | |
| L.int64LE (fromIntegral (L.length x)) <> | |
| L.lazyByteString x | |
| encodeChar :: Char -> L.Builder | |
| encodeChar = L.int64LE . fromIntegral . fromEnum | |
| encodeArray :: [L.Builder] -> L.Builder | |
| encodeArray v = L.int64LE (fromIntegral (length v)) <> mconcat v |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment