Skip to content

Instantly share code, notes, and snippets.

@chrisdone chrisdone/Main.hs Secret
Created Nov 30, 2018

Embed
What would you like to do?
-- <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
You can’t perform that action at this time.